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 */
2360 REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, convert);
2362 /* Finish populating the prev field of the wordinfo array. Walk back
2363 * from each accept state until we find another accept state, and if
2364 * so, point the first word's .prev field at the second word. If the
2365 * second already has a .prev field set, stop now. This will be the
2366 * case either if we've already processed that word's accept state,
2367 * or that state had multiple words, and the overspill words were
2368 * already linked up earlier.
2375 for (word=1; word <= trie->wordcount; word++) {
2377 if (trie->wordinfo[word].prev)
2379 state = trie->wordinfo[word].accept;
2381 state = prev_states[state];
2384 prev = trie->states[state].wordnum;
2388 trie->wordinfo[word].prev = prev;
2390 Safefree(prev_states);
2394 /* and now dump out the compressed format */
2395 DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
2397 RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2399 RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2400 RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2402 SvREFCNT_dec(revcharmap);
2406 : trie->startstate>1
2412 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source, regnode *stclass, U32 depth)
2414 /* The Trie is constructed and compressed now so we can build a fail array if it's needed
2416 This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
2417 "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
2420 We find the fail state for each state in the trie, this state is the longest proper
2421 suffix of the current state's 'word' that is also a proper prefix of another word in our
2422 trie. State 1 represents the word '' and is thus the default fail state. This allows
2423 the DFA not to have to restart after its tried and failed a word at a given point, it
2424 simply continues as though it had been matching the other word in the first place.
2426 'abcdgu'=~/abcdefg|cdgu/
2427 When we get to 'd' we are still matching the first word, we would encounter 'g' which would
2428 fail, which would bring us to the state representing 'd' in the second word where we would
2429 try 'g' and succeed, proceeding to match 'cdgu'.
2431 /* add a fail transition */
2432 const U32 trie_offset = ARG(source);
2433 reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
2435 const U32 ucharcount = trie->uniquecharcount;
2436 const U32 numstates = trie->statecount;
2437 const U32 ubound = trie->lasttrans + ucharcount;
2441 U32 base = trie->states[ 1 ].trans.base;
2444 const U32 data_slot = add_data( pRExC_state, 1, "T" );
2445 GET_RE_DEBUG_FLAGS_DECL;
2447 PERL_ARGS_ASSERT_MAKE_TRIE_FAILTABLE;
2449 PERL_UNUSED_ARG(depth);
2453 ARG_SET( stclass, data_slot );
2454 aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
2455 RExC_rxi->data->data[ data_slot ] = (void*)aho;
2456 aho->trie=trie_offset;
2457 aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
2458 Copy( trie->states, aho->states, numstates, reg_trie_state );
2459 Newxz( q, numstates, U32);
2460 aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
2463 /* initialize fail[0..1] to be 1 so that we always have
2464 a valid final fail state */
2465 fail[ 0 ] = fail[ 1 ] = 1;
2467 for ( charid = 0; charid < ucharcount ; charid++ ) {
2468 const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2470 q[ q_write ] = newstate;
2471 /* set to point at the root */
2472 fail[ q[ q_write++ ] ]=1;
2475 while ( q_read < q_write) {
2476 const U32 cur = q[ q_read++ % numstates ];
2477 base = trie->states[ cur ].trans.base;
2479 for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2480 const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2482 U32 fail_state = cur;
2485 fail_state = fail[ fail_state ];
2486 fail_base = aho->states[ fail_state ].trans.base;
2487 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2489 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2490 fail[ ch_state ] = fail_state;
2491 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2493 aho->states[ ch_state ].wordnum = aho->states[ fail_state ].wordnum;
2495 q[ q_write++ % numstates] = ch_state;
2499 /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2500 when we fail in state 1, this allows us to use the
2501 charclass scan to find a valid start char. This is based on the principle
2502 that theres a good chance the string being searched contains lots of stuff
2503 that cant be a start char.
2505 fail[ 0 ] = fail[ 1 ] = 0;
2506 DEBUG_TRIE_COMPILE_r({
2507 PerlIO_printf(Perl_debug_log,
2508 "%*sStclass Failtable (%"UVuf" states): 0",
2509 (int)(depth * 2), "", (UV)numstates
2511 for( q_read=1; q_read<numstates; q_read++ ) {
2512 PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2514 PerlIO_printf(Perl_debug_log, "\n");
2517 /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2522 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2523 * These need to be revisited when a newer toolchain becomes available.
2525 #if defined(__sparc64__) && defined(__GNUC__)
2526 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2527 # undef SPARC64_GCC_WORKAROUND
2528 # define SPARC64_GCC_WORKAROUND 1
2532 #define DEBUG_PEEP(str,scan,depth) \
2533 DEBUG_OPTIMISE_r({if (scan){ \
2534 SV * const mysv=sv_newmortal(); \
2535 regnode *Next = regnext(scan); \
2536 regprop(RExC_rx, mysv, scan); \
2537 PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
2538 (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2539 Next ? (REG_NODE_NUM(Next)) : 0 ); \
2543 /* The below joins as many adjacent EXACTish nodes as possible into a single
2544 * one, and looks for problematic sequences of characters whose folds vs.
2545 * non-folds have sufficiently different lengths, that the optimizer would be
2546 * fooled into rejecting legitimate matches of them, and the trie construction
2547 * code can't cope with them. The joining is only done if:
2548 * 1) there is room in the current conglomerated node to entirely contain the
2550 * 2) they are the exact same node type
2552 * The adjacent nodes actually may be separated by NOTHING kind nodes, and
2553 * these get optimized out
2555 * If there are problematic code sequences, *min_subtract is set to the delta
2556 * that the minimum size of the node can be less than its actual size. And,
2557 * the node type of the result is changed to reflect that it contains these
2560 * And *has_exactf_sharp_s is set to indicate whether or not the node is EXACTF
2561 * and contains LATIN SMALL LETTER SHARP S
2563 * This is as good a place as any to discuss the design of handling these
2564 * problematic sequences. It's been wrong in Perl for a very long time. There
2565 * are three code points in Unicode whose folded lengths differ so much from
2566 * the un-folded lengths that it causes problems for the optimizer and trie
2567 * construction. Why only these are problematic, and not others where lengths
2568 * also differ is something I (khw) do not understand. New versions of Unicode
2569 * might add more such code points. Hopefully the logic in fold_grind.t that
2570 * figures out what to test (in part by verifying that each size-combination
2571 * gets tested) will catch any that do come along, so they can be added to the
2572 * special handling below. The chances of new ones are actually rather small,
2573 * as most, if not all, of the world's scripts that have casefolding have
2574 * already been encoded by Unicode. Also, a number of Unicode's decisions were
2575 * made to allow compatibility with pre-existing standards, and almost all of
2576 * those have already been dealt with. These would otherwise be the most
2577 * likely candidates for generating further tricky sequences. In other words,
2578 * Unicode by itself is unlikely to add new ones unless it is for compatibility
2579 * with pre-existing standards, and there aren't many of those left.
2581 * The previous designs for dealing with these involved assigning a special
2582 * node for them. This approach doesn't work, as evidenced by this example:
2583 * "\xDFs" =~ /s\xDF/ui # Used to fail before these patches
2584 * Both these fold to "sss", but if the pattern is parsed to create a node of
2585 * that would match just the \xDF, it won't be able to handle the case where a
2586 * successful match would have to cross the node's boundary. The new approach
2587 * that hopefully generally solves the problem generates an EXACTFU_SS node
2590 * There are a number of components to the approach (a lot of work for just
2591 * three code points!):
2592 * 1) This routine examines each EXACTFish node that could contain the
2593 * problematic sequences. It returns in *min_subtract how much to
2594 * subtract from the the actual length of the string to get a real minimum
2595 * for one that could match it. This number is usually 0 except for the
2596 * problematic sequences. This delta is used by the caller to adjust the
2597 * min length of the match, and the delta between min and max, so that the
2598 * optimizer doesn't reject these possibilities based on size constraints.
2599 * 2) These sequences are not currently correctly handled by the trie code
2600 * either, so it changes the joined node type to ops that are not handled
2601 * by trie's, those new ops being EXACTFU_SS and EXACTFU_TRICKYFOLD.
2602 * 3) This is sufficient for the two Greek sequences (described below), but
2603 * the one involving the Sharp s (\xDF) needs more. The node type
2604 * EXACTFU_SS is used for an EXACTFU node that contains at least one "ss"
2605 * sequence in it. For non-UTF-8 patterns and strings, this is the only
2606 * case where there is a possible fold length change. That means that a
2607 * regular EXACTFU node without UTF-8 involvement doesn't have to concern
2608 * itself with length changes, and so can be processed faster. regexec.c
2609 * takes advantage of this. Generally, an EXACTFish node that is in UTF-8
2610 * is pre-folded by regcomp.c. This saves effort in regex matching.
2611 * However, probably mostly for historical reasons, the pre-folding isn't
2612 * done for non-UTF8 patterns (and it can't be for EXACTF and EXACTFL
2613 * nodes, as what they fold to isn't known until runtime.) The fold
2614 * possibilities for the non-UTF8 patterns are quite simple, except for
2615 * the sharp s. All the ones that don't involve a UTF-8 target string
2616 * are members of a fold-pair, and arrays are set up for all of them
2617 * that quickly find the other member of the pair. It might actually
2618 * be faster to pre-fold these, but it isn't currently done, except for
2619 * the sharp s. Code elsewhere in this file makes sure that it gets
2620 * folded to 'ss', even if the pattern isn't UTF-8. This avoids the
2621 * issues described in the next item.
2622 * 4) A problem remains for the sharp s in EXACTF nodes. Whether it matches
2623 * 'ss' or not is not knowable at compile time. It will match iff the
2624 * target string is in UTF-8, unlike the EXACTFU nodes, where it always
2625 * matches; and the EXACTFL and EXACTFA nodes where it never does. Thus
2626 * it can't be folded to "ss" at compile time, unlike EXACTFU does as
2627 * described in item 3). An assumption that the optimizer part of
2628 * regexec.c (probably unwittingly) makes is that a character in the
2629 * pattern corresponds to at most a single character in the target string.
2630 * (And I do mean character, and not byte here, unlike other parts of the
2631 * documentation that have never been updated to account for multibyte
2632 * Unicode.) This assumption is wrong only in this case, as all other
2633 * cases are either 1-1 folds when no UTF-8 is involved; or is true by
2634 * virtue of having this file pre-fold UTF-8 patterns. I'm
2635 * reluctant to try to change this assumption, so instead the code punts.
2636 * This routine examines EXACTF nodes for the sharp s, and returns a
2637 * boolean indicating whether or not the node is an EXACTF node that
2638 * contains a sharp s. When it is true, the caller sets a flag that later
2639 * causes the optimizer in this file to not set values for the floating
2640 * and fixed string lengths, and thus avoids the optimizer code in
2641 * regexec.c that makes the invalid assumption. Thus, there is no
2642 * optimization based on string lengths for EXACTF nodes that contain the
2643 * sharp s. This only happens for /id rules (which means the pattern
2647 #define JOIN_EXACT(scan,min_subtract,has_exactf_sharp_s, flags) \
2648 if (PL_regkind[OP(scan)] == EXACT) \
2649 join_exact(pRExC_state,(scan),(min_subtract),has_exactf_sharp_s, (flags),NULL,depth+1)
2652 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) {
2653 /* Merge several consecutive EXACTish nodes into one. */
2654 regnode *n = regnext(scan);
2656 regnode *next = scan + NODE_SZ_STR(scan);
2660 regnode *stop = scan;
2661 GET_RE_DEBUG_FLAGS_DECL;
2663 PERL_UNUSED_ARG(depth);
2666 PERL_ARGS_ASSERT_JOIN_EXACT;
2667 #ifndef EXPERIMENTAL_INPLACESCAN
2668 PERL_UNUSED_ARG(flags);
2669 PERL_UNUSED_ARG(val);
2671 DEBUG_PEEP("join",scan,depth);
2673 /* Look through the subsequent nodes in the chain. Skip NOTHING, merge
2674 * EXACT ones that are mergeable to the current one. */
2676 && (PL_regkind[OP(n)] == NOTHING
2677 || (stringok && OP(n) == OP(scan)))
2679 && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
2682 if (OP(n) == TAIL || n > next)
2684 if (PL_regkind[OP(n)] == NOTHING) {
2685 DEBUG_PEEP("skip:",n,depth);
2686 NEXT_OFF(scan) += NEXT_OFF(n);
2687 next = n + NODE_STEP_REGNODE;
2694 else if (stringok) {
2695 const unsigned int oldl = STR_LEN(scan);
2696 regnode * const nnext = regnext(n);
2698 if (oldl + STR_LEN(n) > U8_MAX)
2701 DEBUG_PEEP("merg",n,depth);
2704 NEXT_OFF(scan) += NEXT_OFF(n);
2705 STR_LEN(scan) += STR_LEN(n);
2706 next = n + NODE_SZ_STR(n);
2707 /* Now we can overwrite *n : */
2708 Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2716 #ifdef EXPERIMENTAL_INPLACESCAN
2717 if (flags && !NEXT_OFF(n)) {
2718 DEBUG_PEEP("atch", val, depth);
2719 if (reg_off_by_arg[OP(n)]) {
2720 ARG_SET(n, val - n);
2723 NEXT_OFF(n) = val - n;
2731 *has_exactf_sharp_s = FALSE;
2733 /* Here, all the adjacent mergeable EXACTish nodes have been merged. We
2734 * can now analyze for sequences of problematic code points. (Prior to
2735 * this final joining, sequences could have been split over boundaries, and
2736 * hence missed). The sequences only happen in folding, hence for any
2737 * non-EXACT EXACTish node */
2738 if (OP(scan) != EXACT) {
2740 U8 * s0 = (U8*) STRING(scan);
2741 U8 * const s_end = s0 + STR_LEN(scan);
2743 /* The below is perhaps overboard, but this allows us to save a test
2744 * each time through the loop at the expense of a mask. This is
2745 * because on both EBCDIC and ASCII machines, 'S' and 's' differ by a
2746 * single bit. On ASCII they are 32 apart; on EBCDIC, they are 64.
2747 * This uses an exclusive 'or' to find that bit and then inverts it to
2748 * form a mask, with just a single 0, in the bit position where 'S' and
2750 const U8 S_or_s_mask = (U8) ~ ('S' ^ 's');
2751 const U8 s_masked = 's' & S_or_s_mask;
2753 /* One pass is made over the node's string looking for all the
2754 * possibilities. to avoid some tests in the loop, there are two main
2755 * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
2759 /* There are two problematic Greek code points in Unicode
2762 * U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
2763 * U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
2769 * U+03B9 U+0308 U+0301 0xCE 0xB9 0xCC 0x88 0xCC 0x81
2770 * U+03C5 U+0308 U+0301 0xCF 0x85 0xCC 0x88 0xCC 0x81
2772 * This means that in case-insensitive matching (or "loose
2773 * matching", as Unicode calls it), an EXACTF of length six (the
2774 * UTF-8 encoded byte length of the above casefolded versions) can
2775 * match a target string of length two (the byte length of UTF-8
2776 * encoded U+0390 or U+03B0). This would rather mess up the
2777 * minimum length computation. (there are other code points that
2778 * also fold to these two sequences, but the delta is smaller)
2780 * If these sequences are found, the minimum length is decreased by
2781 * four (six minus two).
2783 * Similarly, 'ss' may match the single char and byte LATIN SMALL
2784 * LETTER SHARP S. We decrease the min length by 1 for each
2785 * occurrence of 'ss' found */
2787 #ifdef EBCDIC /* RD tunifold greek 0390 and 03B0 */
2788 # define U390_first_byte 0xb4
2789 const U8 U390_tail[] = "\x68\xaf\x49\xaf\x42";
2790 # define U3B0_first_byte 0xb5
2791 const U8 U3B0_tail[] = "\x46\xaf\x49\xaf\x42";
2793 # define U390_first_byte 0xce
2794 const U8 U390_tail[] = "\xb9\xcc\x88\xcc\x81";
2795 # define U3B0_first_byte 0xcf
2796 const U8 U3B0_tail[] = "\x85\xcc\x88\xcc\x81";
2798 const U8 len = sizeof(U390_tail); /* (-1 for NUL; +1 for 1st byte;
2799 yields a net of 0 */
2800 /* Examine the string for one of the problematic sequences */
2802 s < s_end - 1; /* Can stop 1 before the end, as minimum length
2803 * sequence we are looking for is 2 */
2807 /* Look for the first byte in each problematic sequence */
2809 /* We don't have to worry about other things that fold to
2810 * 's' (such as the long s, U+017F), as all above-latin1
2811 * code points have been pre-folded */
2815 /* Current character is an 's' or 'S'. If next one is
2816 * as well, we have the dreaded sequence */
2817 if (((*(s+1) & S_or_s_mask) == s_masked)
2818 /* These two node types don't have special handling
2820 && OP(scan) != EXACTFL && OP(scan) != EXACTFA)
2823 OP(scan) = EXACTFU_SS;
2824 s++; /* No need to look at this character again */
2828 case U390_first_byte:
2829 if (s_end - s >= len
2831 /* The 1's are because are skipping comparing the
2833 && memEQ(s + 1, U390_tail, len - 1))
2835 goto greek_sequence;
2839 case U3B0_first_byte:
2840 if (! (s_end - s >= len
2841 && memEQ(s + 1, U3B0_tail, len - 1)))
2848 /* This can't currently be handled by trie's, so change
2849 * the node type to indicate this. If EXACTFA and
2850 * EXACTFL were ever to be handled by trie's, this
2851 * would have to be changed. If this node has already
2852 * been changed to EXACTFU_SS in this loop, leave it as
2853 * is. (I (khw) think it doesn't matter in regexec.c
2854 * for UTF patterns, but no need to change it */
2855 if (OP(scan) == EXACTFU) {
2856 OP(scan) = EXACTFU_TRICKYFOLD;
2858 s += 6; /* We already know what this sequence is. Skip
2864 else if (OP(scan) != EXACTFL && OP(scan) != EXACTFA) {
2866 /* Here, the pattern is not UTF-8. We need to look only for the
2867 * 'ss' sequence, and in the EXACTF case, the sharp s, which can be
2868 * in the final position. Otherwise we can stop looking 1 byte
2869 * earlier because have to find both the first and second 's' */
2870 const U8* upper = (OP(scan) == EXACTF) ? s_end : s_end -1;
2872 for (s = s0; s < upper; s++) {
2877 && ((*(s+1) & S_or_s_mask) == s_masked))
2881 /* EXACTF nodes need to know that the minimum
2882 * length changed so that a sharp s in the string
2883 * can match this ss in the pattern, but they
2884 * remain EXACTF nodes, as they are not trie'able,
2885 * so don't have to invent a new node type to
2886 * exclude them from the trie code */
2887 if (OP(scan) != EXACTF) {
2888 OP(scan) = EXACTFU_SS;
2893 case LATIN_SMALL_LETTER_SHARP_S:
2894 if (OP(scan) == EXACTF) {
2895 *has_exactf_sharp_s = TRUE;
2904 /* Allow dumping but overwriting the collection of skipped
2905 * ops and/or strings with fake optimized ops */
2906 n = scan + NODE_SZ_STR(scan);
2914 DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2918 /* REx optimizer. Converts nodes into quicker variants "in place".
2919 Finds fixed substrings. */
2921 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
2922 to the position after last scanned or to NULL. */
2924 #define INIT_AND_WITHP \
2925 assert(!and_withp); \
2926 Newx(and_withp,1,struct regnode_charclass_class); \
2927 SAVEFREEPV(and_withp)
2929 /* this is a chain of data about sub patterns we are processing that
2930 need to be handled separately/specially in study_chunk. Its so
2931 we can simulate recursion without losing state. */
2933 typedef struct scan_frame {
2934 regnode *last; /* last node to process in this frame */
2935 regnode *next; /* next node to process when last is reached */
2936 struct scan_frame *prev; /*previous frame*/
2937 I32 stop; /* what stopparen do we use */
2941 #define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
2943 #define CASE_SYNST_FNC(nAmE) \
2945 if (flags & SCF_DO_STCLASS_AND) { \
2946 for (value = 0; value < 256; value++) \
2947 if (!is_ ## nAmE ## _cp(value)) \
2948 ANYOF_BITMAP_CLEAR(data->start_class, value); \
2951 for (value = 0; value < 256; value++) \
2952 if (is_ ## nAmE ## _cp(value)) \
2953 ANYOF_BITMAP_SET(data->start_class, value); \
2957 if (flags & SCF_DO_STCLASS_AND) { \
2958 for (value = 0; value < 256; value++) \
2959 if (is_ ## nAmE ## _cp(value)) \
2960 ANYOF_BITMAP_CLEAR(data->start_class, value); \
2963 for (value = 0; value < 256; value++) \
2964 if (!is_ ## nAmE ## _cp(value)) \
2965 ANYOF_BITMAP_SET(data->start_class, value); \
2972 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
2973 I32 *minlenp, I32 *deltap,
2978 struct regnode_charclass_class *and_withp,
2979 U32 flags, U32 depth)
2980 /* scanp: Start here (read-write). */
2981 /* deltap: Write maxlen-minlen here. */
2982 /* last: Stop before this one. */
2983 /* data: string data about the pattern */
2984 /* stopparen: treat close N as END */
2985 /* recursed: which subroutines have we recursed into */
2986 /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
2989 I32 min = 0, pars = 0, code;
2990 regnode *scan = *scanp, *next;
2992 int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
2993 int is_inf_internal = 0; /* The studied chunk is infinite */
2994 I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
2995 scan_data_t data_fake;
2996 SV *re_trie_maxbuff = NULL;
2997 regnode *first_non_open = scan;
2998 I32 stopmin = I32_MAX;
2999 scan_frame *frame = NULL;
3000 GET_RE_DEBUG_FLAGS_DECL;
3002 PERL_ARGS_ASSERT_STUDY_CHUNK;
3005 StructCopy(&zero_scan_data, &data_fake, scan_data_t);
3009 while (first_non_open && OP(first_non_open) == OPEN)
3010 first_non_open=regnext(first_non_open);
3015 while ( scan && OP(scan) != END && scan < last ){
3016 UV min_subtract = 0; /* How much to subtract from the minimum node
3017 length to get a real minimum (because the
3018 folded version may be shorter) */
3019 bool has_exactf_sharp_s = FALSE;
3020 /* Peephole optimizer: */
3021 DEBUG_STUDYDATA("Peep:", data,depth);
3022 DEBUG_PEEP("Peep",scan,depth);
3024 /* Its not clear to khw or hv why this is done here, and not in the
3025 * clauses that deal with EXACT nodes. khw's guess is that it's
3026 * because of a previous design */
3027 JOIN_EXACT(scan,&min_subtract, &has_exactf_sharp_s, 0);
3029 /* Follow the next-chain of the current node and optimize
3030 away all the NOTHINGs from it. */
3031 if (OP(scan) != CURLYX) {
3032 const int max = (reg_off_by_arg[OP(scan)]
3034 /* I32 may be smaller than U16 on CRAYs! */
3035 : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
3036 int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
3040 /* Skip NOTHING and LONGJMP. */
3041 while ((n = regnext(n))
3042 && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
3043 || ((OP(n) == LONGJMP) && (noff = ARG(n))))
3044 && off + noff < max)
3046 if (reg_off_by_arg[OP(scan)])
3049 NEXT_OFF(scan) = off;
3054 /* The principal pseudo-switch. Cannot be a switch, since we
3055 look into several different things. */
3056 if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
3057 || OP(scan) == IFTHEN) {
3058 next = regnext(scan);
3060 /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
3062 if (OP(next) == code || code == IFTHEN) {
3063 /* NOTE - There is similar code to this block below for handling
3064 TRIE nodes on a re-study. If you change stuff here check there
3066 I32 max1 = 0, min1 = I32_MAX, num = 0;
3067 struct regnode_charclass_class accum;
3068 regnode * const startbranch=scan;
3070 if (flags & SCF_DO_SUBSTR)
3071 SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
3072 if (flags & SCF_DO_STCLASS)
3073 cl_init_zero(pRExC_state, &accum);
3075 while (OP(scan) == code) {
3076 I32 deltanext, minnext, f = 0, fake;
3077 struct regnode_charclass_class this_class;
3080 data_fake.flags = 0;
3082 data_fake.whilem_c = data->whilem_c;
3083 data_fake.last_closep = data->last_closep;
3086 data_fake.last_closep = &fake;
3088 data_fake.pos_delta = delta;
3089 next = regnext(scan);
3090 scan = NEXTOPER(scan);
3092 scan = NEXTOPER(scan);
3093 if (flags & SCF_DO_STCLASS) {
3094 cl_init(pRExC_state, &this_class);
3095 data_fake.start_class = &this_class;
3096 f = SCF_DO_STCLASS_AND;
3098 if (flags & SCF_WHILEM_VISITED_POS)
3099 f |= SCF_WHILEM_VISITED_POS;
3101 /* we suppose the run is continuous, last=next...*/
3102 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
3104 stopparen, recursed, NULL, f,depth+1);
3107 if (max1 < minnext + deltanext)
3108 max1 = minnext + deltanext;
3109 if (deltanext == I32_MAX)
3110 is_inf = is_inf_internal = 1;
3112 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3114 if (data_fake.flags & SCF_SEEN_ACCEPT) {
3115 if ( stopmin > minnext)
3116 stopmin = min + min1;
3117 flags &= ~SCF_DO_SUBSTR;
3119 data->flags |= SCF_SEEN_ACCEPT;
3122 if (data_fake.flags & SF_HAS_EVAL)
3123 data->flags |= SF_HAS_EVAL;
3124 data->whilem_c = data_fake.whilem_c;
3126 if (flags & SCF_DO_STCLASS)
3127 cl_or(pRExC_state, &accum, &this_class);
3129 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
3131 if (flags & SCF_DO_SUBSTR) {
3132 data->pos_min += min1;
3133 data->pos_delta += max1 - min1;
3134 if (max1 != min1 || is_inf)
3135 data->longest = &(data->longest_float);
3138 delta += max1 - min1;
3139 if (flags & SCF_DO_STCLASS_OR) {
3140 cl_or(pRExC_state, data->start_class, &accum);
3142 cl_and(data->start_class, and_withp);
3143 flags &= ~SCF_DO_STCLASS;
3146 else if (flags & SCF_DO_STCLASS_AND) {
3148 cl_and(data->start_class, &accum);
3149 flags &= ~SCF_DO_STCLASS;
3152 /* Switch to OR mode: cache the old value of
3153 * data->start_class */
3155 StructCopy(data->start_class, and_withp,
3156 struct regnode_charclass_class);
3157 flags &= ~SCF_DO_STCLASS_AND;
3158 StructCopy(&accum, data->start_class,
3159 struct regnode_charclass_class);
3160 flags |= SCF_DO_STCLASS_OR;
3161 data->start_class->flags |= ANYOF_EOS;
3165 if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
3168 Assuming this was/is a branch we are dealing with: 'scan' now
3169 points at the item that follows the branch sequence, whatever
3170 it is. We now start at the beginning of the sequence and look
3177 which would be constructed from a pattern like /A|LIST|OF|WORDS/
3179 If we can find such a subsequence we need to turn the first
3180 element into a trie and then add the subsequent branch exact
3181 strings to the trie.
3185 1. patterns where the whole set of branches can be converted.
3187 2. patterns where only a subset can be converted.
3189 In case 1 we can replace the whole set with a single regop
3190 for the trie. In case 2 we need to keep the start and end
3193 'BRANCH EXACT; BRANCH EXACT; BRANCH X'
3194 becomes BRANCH TRIE; BRANCH X;
3196 There is an additional case, that being where there is a
3197 common prefix, which gets split out into an EXACT like node
3198 preceding the TRIE node.
3200 If x(1..n)==tail then we can do a simple trie, if not we make
3201 a "jump" trie, such that when we match the appropriate word
3202 we "jump" to the appropriate tail node. Essentially we turn
3203 a nested if into a case structure of sorts.
3208 if (!re_trie_maxbuff) {
3209 re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
3210 if (!SvIOK(re_trie_maxbuff))
3211 sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
3213 if ( SvIV(re_trie_maxbuff)>=0 ) {
3215 regnode *first = (regnode *)NULL;
3216 regnode *last = (regnode *)NULL;
3217 regnode *tail = scan;
3222 SV * const mysv = sv_newmortal(); /* for dumping */
3224 /* var tail is used because there may be a TAIL
3225 regop in the way. Ie, the exacts will point to the
3226 thing following the TAIL, but the last branch will
3227 point at the TAIL. So we advance tail. If we
3228 have nested (?:) we may have to move through several
3232 while ( OP( tail ) == TAIL ) {
3233 /* this is the TAIL generated by (?:) */
3234 tail = regnext( tail );
3239 regprop(RExC_rx, mysv, tail );
3240 PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
3241 (int)depth * 2 + 2, "",
3242 "Looking for TRIE'able sequences. Tail node is: ",
3243 SvPV_nolen_const( mysv )
3249 Step through the branches
3250 cur represents each branch,
3251 noper is the first thing to be matched as part of that branch
3252 noper_next is the regnext() of that node.
3254 We normally handle a case like this /FOO[xyz]|BAR[pqr]/
3255 via a "jump trie" but we also support building with NOJUMPTRIE,
3256 which restricts the trie logic to structures like /FOO|BAR/.
3258 If noper is a trieable nodetype then the branch is a possible optimization
3259 target. If we are building under NOJUMPTRIE then we require that noper_next
3260 is the same as scan (our current position in the regex program).
3262 Once we have two or more consecutive such branches we can create a
3263 trie of the EXACT's contents and stitch it in place into the program.
3265 If the sequence represents all of the branches in the alternation we
3266 replace the entire thing with a single TRIE node.
3268 Otherwise when it is a subsequence we need to stitch it in place and
3269 replace only the relevant branches. This means the first branch has
3270 to remain as it is used by the alternation logic, and its next pointer,
3271 and needs to be repointed at the item on the branch chain following
3272 the last branch we have optimized away.
3274 This could be either a BRANCH, in which case the subsequence is internal,
3275 or it could be the item following the branch sequence in which case the
3276 subsequence is at the end (which does not necessarily mean the first node
3277 is the start of the alternation).
3279 TRIE_TYPE(X) is a define which maps the optype to a trietype.
3282 ----------------+-----------
3286 EXACTFU_SS | EXACTFU
3287 EXACTFU_TRICKYFOLD | EXACTFU
3292 #define TRIE_TYPE(X) ( ( NOTHING == (X) ) ? NOTHING : \
3293 ( EXACT == (X) ) ? EXACT : \
3294 ( EXACTFU == (X) || EXACTFU_SS == (X) || EXACTFU_TRICKYFOLD == (X) ) ? EXACTFU : \
3297 /* dont use tail as the end marker for this traverse */
3298 for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
3299 regnode * const noper = NEXTOPER( cur );
3300 U8 noper_type = OP( noper );
3301 U8 noper_trietype = TRIE_TYPE( noper_type );
3302 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
3303 regnode * const noper_next = regnext( noper );
3307 regprop(RExC_rx, mysv, cur);
3308 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
3309 (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
3311 regprop(RExC_rx, mysv, noper);
3312 PerlIO_printf( Perl_debug_log, " -> %s",
3313 SvPV_nolen_const(mysv));
3316 regprop(RExC_rx, mysv, noper_next );
3317 PerlIO_printf( Perl_debug_log,"\t=> %s\t",
3318 SvPV_nolen_const(mysv));
3320 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d)\n",
3321 REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur) );
3324 /* Is noper a trieable nodetype that can be merged with the
3325 * current trie (if there is one)? */
3329 /* XXX: Currently we cannot allow a NOTHING node to be the first element
3330 * of a TRIEABLE sequence, Otherwise we will overwrite the regop following
3331 * the NOTHING with the TRIE regop later on. This is because a NOTHING node
3332 * is only one regnode wide, and a TRIE is two regnodes. An example of a
3333 * problematic pattern is: "x" =~ /\A(?>(?:(?:)A|B|C?x))\z/
3334 * At a later point of time we can somewhat workaround this by handling
3335 * NOTHING -> EXACT sequences as generated by /(?:)A|(?:)B/ type patterns,
3336 * as we can effectively ignore the NOTHING regop in that case.
3337 * This clause, which allows NOTHING to start a sequence is left commented
3338 * out as a reference.
3341 ( noper_trietype == NOTHING)
3342 || ( trietype == NOTHING )
3344 ( noper_trietype == NOTHING && trietype )
3345 || ( trietype == noper_trietype )
3348 && noper_next == tail
3352 /* Handle mergable triable node
3353 * Either we are the first node in a new trieable sequence,
3354 * in which case we do some bookkeeping, otherwise we update
3355 * the end pointer. */
3359 trietype = noper_trietype;
3361 if ( trietype == NOTHING )
3362 trietype = noper_trietype;
3365 } /* end handle mergable triable node */
3367 /* handle unmergable node -
3368 * noper may either be a triable node which can not be tried
3369 * together with the current trie, or a non triable node */
3371 /* If last is set and trietype is not NOTHING then we have found
3372 * at least two triable branch sequences in a row of a similar
3373 * trietype so we can turn them into a trie. If/when we
3374 * allow NOTHING to start a trie sequence this condition will be
3375 * required, and it isn't expensive so we leave it in for now. */
3376 if ( trietype != NOTHING )
3377 make_trie( pRExC_state,
3378 startbranch, first, cur, tail, count,
3379 trietype, depth+1 );
3380 last = NULL; /* note: we clear/update first, trietype etc below, so we dont do it here */
3384 && noper_next == tail
3387 /* noper is triable, so we can start a new trie sequence */
3390 trietype = noper_trietype;
3392 /* if we already saw a first but the current node is not triable then we have
3393 * to reset the first information. */
3398 } /* end handle unmergable node */
3399 } /* loop over branches */
3401 regprop(RExC_rx, mysv, cur);
3402 PerlIO_printf( Perl_debug_log,
3403 "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
3404 "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3407 if ( last && trietype != NOTHING ) {
3408 /* the last branch of the sequence was part of a trie,
3409 * so we have to construct it here outside of the loop
3411 made= make_trie( pRExC_state, startbranch, first, scan, tail, count, trietype, depth+1 );
3412 #ifdef TRIE_STUDY_OPT
3413 if ( ((made == MADE_EXACT_TRIE &&
3414 startbranch == first)
3415 || ( first_non_open == first )) &&
3417 flags |= SCF_TRIE_RESTUDY;
3418 if ( startbranch == first
3421 RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
3425 } /* end if ( last) */
3426 } /* TRIE_MAXBUF is non zero */
3431 else if ( code == BRANCHJ ) { /* single branch is optimized. */
3432 scan = NEXTOPER(NEXTOPER(scan));
3433 } else /* single branch is optimized. */
3434 scan = NEXTOPER(scan);
3436 } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
3437 scan_frame *newframe = NULL;
3442 if (OP(scan) != SUSPEND) {
3443 /* set the pointer */
3444 if (OP(scan) == GOSUB) {
3446 RExC_recurse[ARG2L(scan)] = scan;
3447 start = RExC_open_parens[paren-1];
3448 end = RExC_close_parens[paren-1];
3451 start = RExC_rxi->program + 1;
3455 Newxz(recursed, (((RExC_npar)>>3) +1), U8);
3456 SAVEFREEPV(recursed);
3458 if (!PAREN_TEST(recursed,paren+1)) {
3459 PAREN_SET(recursed,paren+1);
3460 Newx(newframe,1,scan_frame);
3462 if (flags & SCF_DO_SUBSTR) {
3463 SCAN_COMMIT(pRExC_state,data,minlenp);
3464 data->longest = &(data->longest_float);
3466 is_inf = is_inf_internal = 1;
3467 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3468 cl_anything(pRExC_state, data->start_class);
3469 flags &= ~SCF_DO_STCLASS;
3472 Newx(newframe,1,scan_frame);
3475 end = regnext(scan);
3480 SAVEFREEPV(newframe);
3481 newframe->next = regnext(scan);
3482 newframe->last = last;
3483 newframe->stop = stopparen;
3484 newframe->prev = frame;
3494 else if (OP(scan) == EXACT) {
3495 I32 l = STR_LEN(scan);
3498 const U8 * const s = (U8*)STRING(scan);
3499 uc = utf8_to_uvchr_buf(s, s + l, NULL);
3500 l = utf8_length(s, s + l);
3502 uc = *((U8*)STRING(scan));
3505 if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
3506 /* The code below prefers earlier match for fixed
3507 offset, later match for variable offset. */
3508 if (data->last_end == -1) { /* Update the start info. */
3509 data->last_start_min = data->pos_min;
3510 data->last_start_max = is_inf
3511 ? I32_MAX : data->pos_min + data->pos_delta;
3513 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
3515 SvUTF8_on(data->last_found);
3517 SV * const sv = data->last_found;
3518 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3519 mg_find(sv, PERL_MAGIC_utf8) : NULL;
3520 if (mg && mg->mg_len >= 0)
3521 mg->mg_len += utf8_length((U8*)STRING(scan),
3522 (U8*)STRING(scan)+STR_LEN(scan));
3524 data->last_end = data->pos_min + l;
3525 data->pos_min += l; /* As in the first entry. */
3526 data->flags &= ~SF_BEFORE_EOL;
3528 if (flags & SCF_DO_STCLASS_AND) {
3529 /* Check whether it is compatible with what we know already! */
3533 /* If compatible, we or it in below. It is compatible if is
3534 * in the bitmp and either 1) its bit or its fold is set, or 2)
3535 * it's for a locale. Even if there isn't unicode semantics
3536 * here, at runtime there may be because of matching against a
3537 * utf8 string, so accept a possible false positive for
3538 * latin1-range folds */
3540 (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3541 && !ANYOF_BITMAP_TEST(data->start_class, uc)
3542 && (!(data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD)
3543 || !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3548 ANYOF_CLASS_ZERO(data->start_class);
3549 ANYOF_BITMAP_ZERO(data->start_class);
3551 ANYOF_BITMAP_SET(data->start_class, uc);
3552 else if (uc >= 0x100) {
3555 /* Some Unicode code points fold to the Latin1 range; as
3556 * XXX temporary code, instead of figuring out if this is
3557 * one, just assume it is and set all the start class bits
3558 * that could be some such above 255 code point's fold
3559 * which will generate fals positives. As the code
3560 * elsewhere that does compute the fold settles down, it
3561 * can be extracted out and re-used here */
3562 for (i = 0; i < 256; i++){
3563 if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3564 ANYOF_BITMAP_SET(data->start_class, i);
3568 data->start_class->flags &= ~ANYOF_EOS;
3570 data->start_class->flags &= ~ANYOF_UNICODE_ALL;
3572 else if (flags & SCF_DO_STCLASS_OR) {
3573 /* false positive possible if the class is case-folded */
3575 ANYOF_BITMAP_SET(data->start_class, uc);
3577 data->start_class->flags |= ANYOF_UNICODE_ALL;
3578 data->start_class->flags &= ~ANYOF_EOS;
3579 cl_and(data->start_class, and_withp);
3581 flags &= ~SCF_DO_STCLASS;
3583 else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
3584 I32 l = STR_LEN(scan);
3585 UV uc = *((U8*)STRING(scan));
3587 /* Search for fixed substrings supports EXACT only. */
3588 if (flags & SCF_DO_SUBSTR) {
3590 SCAN_COMMIT(pRExC_state, data, minlenp);
3593 const U8 * const s = (U8 *)STRING(scan);
3594 uc = utf8_to_uvchr_buf(s, s + l, NULL);
3595 l = utf8_length(s, s + l);
3597 else if (has_exactf_sharp_s) {
3598 RExC_seen |= REG_SEEN_EXACTF_SHARP_S;
3600 min += l - min_subtract;
3604 delta += min_subtract;
3605 if (flags & SCF_DO_SUBSTR) {
3606 data->pos_min += l - min_subtract;
3607 if (data->pos_min < 0) {
3610 data->pos_delta += min_subtract;
3612 data->longest = &(data->longest_float);
3615 if (flags & SCF_DO_STCLASS_AND) {
3616 /* Check whether it is compatible with what we know already! */
3619 (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3620 && !ANYOF_BITMAP_TEST(data->start_class, uc)
3621 && !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3625 ANYOF_CLASS_ZERO(data->start_class);
3626 ANYOF_BITMAP_ZERO(data->start_class);
3628 ANYOF_BITMAP_SET(data->start_class, uc);
3629 data->start_class->flags &= ~ANYOF_EOS;
3630 data->start_class->flags |= ANYOF_LOC_NONBITMAP_FOLD;
3631 if (OP(scan) == EXACTFL) {
3632 /* XXX This set is probably no longer necessary, and
3633 * probably wrong as LOCALE now is on in the initial
3635 data->start_class->flags |= ANYOF_LOCALE;
3639 /* Also set the other member of the fold pair. In case
3640 * that unicode semantics is called for at runtime, use
3641 * the full latin1 fold. (Can't do this for locale,
3642 * because not known until runtime) */
3643 ANYOF_BITMAP_SET(data->start_class, PL_fold_latin1[uc]);
3645 /* All other (EXACTFL handled above) folds except under
3646 * /iaa that include s, S, and sharp_s also may include
3648 if (OP(scan) != EXACTFA) {
3649 if (uc == 's' || uc == 'S') {
3650 ANYOF_BITMAP_SET(data->start_class,
3651 LATIN_SMALL_LETTER_SHARP_S);
3653 else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3654 ANYOF_BITMAP_SET(data->start_class, 's');
3655 ANYOF_BITMAP_SET(data->start_class, 'S');
3660 else if (uc >= 0x100) {
3662 for (i = 0; i < 256; i++){
3663 if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3664 ANYOF_BITMAP_SET(data->start_class, i);
3669 else if (flags & SCF_DO_STCLASS_OR) {
3670 if (data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD) {
3671 /* false positive possible if the class is case-folded.
3672 Assume that the locale settings are the same... */
3674 ANYOF_BITMAP_SET(data->start_class, uc);
3675 if (OP(scan) != EXACTFL) {
3677 /* And set the other member of the fold pair, but
3678 * can't do that in locale because not known until
3680 ANYOF_BITMAP_SET(data->start_class,
3681 PL_fold_latin1[uc]);
3683 /* All folds except under /iaa that include s, S,
3684 * and sharp_s also may include the others */
3685 if (OP(scan) != EXACTFA) {
3686 if (uc == 's' || uc == 'S') {
3687 ANYOF_BITMAP_SET(data->start_class,
3688 LATIN_SMALL_LETTER_SHARP_S);
3690 else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3691 ANYOF_BITMAP_SET(data->start_class, 's');
3692 ANYOF_BITMAP_SET(data->start_class, 'S');
3697 data->start_class->flags &= ~ANYOF_EOS;
3699 cl_and(data->start_class, and_withp);
3701 flags &= ~SCF_DO_STCLASS;
3703 else if (REGNODE_VARIES(OP(scan))) {
3704 I32 mincount, maxcount, minnext, deltanext, fl = 0;
3705 I32 f = flags, pos_before = 0;
3706 regnode * const oscan = scan;
3707 struct regnode_charclass_class this_class;
3708 struct regnode_charclass_class *oclass = NULL;
3709 I32 next_is_eval = 0;
3711 switch (PL_regkind[OP(scan)]) {
3712 case WHILEM: /* End of (?:...)* . */
3713 scan = NEXTOPER(scan);
3716 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
3717 next = NEXTOPER(scan);
3718 if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
3720 maxcount = REG_INFTY;
3721 next = regnext(scan);
3722 scan = NEXTOPER(scan);
3726 if (flags & SCF_DO_SUBSTR)
3731 if (flags & SCF_DO_STCLASS) {
3733 maxcount = REG_INFTY;
3734 next = regnext(scan);
3735 scan = NEXTOPER(scan);
3738 is_inf = is_inf_internal = 1;
3739 scan = regnext(scan);
3740 if (flags & SCF_DO_SUBSTR) {
3741 SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
3742 data->longest = &(data->longest_float);
3744 goto optimize_curly_tail;
3746 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
3747 && (scan->flags == stopparen))
3752 mincount = ARG1(scan);
3753 maxcount = ARG2(scan);
3755 next = regnext(scan);
3756 if (OP(scan) == CURLYX) {
3757 I32 lp = (data ? *(data->last_closep) : 0);
3758 scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
3760 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3761 next_is_eval = (OP(scan) == EVAL);
3763 if (flags & SCF_DO_SUBSTR) {
3764 if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
3765 pos_before = data->pos_min;
3769 data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
3771 data->flags |= SF_IS_INF;
3773 if (flags & SCF_DO_STCLASS) {
3774 cl_init(pRExC_state, &this_class);
3775 oclass = data->start_class;
3776 data->start_class = &this_class;
3777 f |= SCF_DO_STCLASS_AND;
3778 f &= ~SCF_DO_STCLASS_OR;
3780 /* Exclude from super-linear cache processing any {n,m}
3781 regops for which the combination of input pos and regex
3782 pos is not enough information to determine if a match
3785 For example, in the regex /foo(bar\s*){4,8}baz/ with the
3786 regex pos at the \s*, the prospects for a match depend not
3787 only on the input position but also on how many (bar\s*)
3788 repeats into the {4,8} we are. */
3789 if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
3790 f &= ~SCF_WHILEM_VISITED_POS;
3792 /* This will finish on WHILEM, setting scan, or on NULL: */
3793 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
3794 last, data, stopparen, recursed, NULL,
3796 ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
3798 if (flags & SCF_DO_STCLASS)
3799 data->start_class = oclass;
3800 if (mincount == 0 || minnext == 0) {
3801 if (flags & SCF_DO_STCLASS_OR) {
3802 cl_or(pRExC_state, data->start_class, &this_class);
3804 else if (flags & SCF_DO_STCLASS_AND) {
3805 /* Switch to OR mode: cache the old value of
3806 * data->start_class */
3808 StructCopy(data->start_class, and_withp,
3809 struct regnode_charclass_class);
3810 flags &= ~SCF_DO_STCLASS_AND;
3811 StructCopy(&this_class, data->start_class,
3812 struct regnode_charclass_class);
3813 flags |= SCF_DO_STCLASS_OR;
3814 data->start_class->flags |= ANYOF_EOS;
3816 } else { /* Non-zero len */
3817 if (flags & SCF_DO_STCLASS_OR) {
3818 cl_or(pRExC_state, data->start_class, &this_class);
3819 cl_and(data->start_class, and_withp);
3821 else if (flags & SCF_DO_STCLASS_AND)
3822 cl_and(data->start_class, &this_class);
3823 flags &= ~SCF_DO_STCLASS;
3825 if (!scan) /* It was not CURLYX, but CURLY. */
3827 if ( /* ? quantifier ok, except for (?{ ... }) */
3828 (next_is_eval || !(mincount == 0 && maxcount == 1))
3829 && (minnext == 0) && (deltanext == 0)
3830 && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3831 && maxcount <= REG_INFTY/3) /* Complement check for big count */
3833 ckWARNreg(RExC_parse,
3834 "Quantifier unexpected on zero-length expression");
3837 min += minnext * mincount;
3838 is_inf_internal |= ((maxcount == REG_INFTY
3839 && (minnext + deltanext) > 0)
3840 || deltanext == I32_MAX);
3841 is_inf |= is_inf_internal;
3842 delta += (minnext + deltanext) * maxcount - minnext * mincount;
3844 /* Try powerful optimization CURLYX => CURLYN. */
3845 if ( OP(oscan) == CURLYX && data
3846 && data->flags & SF_IN_PAR
3847 && !(data->flags & SF_HAS_EVAL)
3848 && !deltanext && minnext == 1 ) {
3849 /* Try to optimize to CURLYN. */
3850 regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3851 regnode * const nxt1 = nxt;
3858 if (!REGNODE_SIMPLE(OP(nxt))
3859 && !(PL_regkind[OP(nxt)] == EXACT
3860 && STR_LEN(nxt) == 1))
3866 if (OP(nxt) != CLOSE)
3868 if (RExC_open_parens) {
3869 RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3870 RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3872 /* Now we know that nxt2 is the only contents: */
3873 oscan->flags = (U8)ARG(nxt);
3875 OP(nxt1) = NOTHING; /* was OPEN. */
3878 OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3879 NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
3880 NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
3881 OP(nxt) = OPTIMIZED; /* was CLOSE. */
3882 OP(nxt + 1) = OPTIMIZED; /* was count. */
3883 NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
3888 /* Try optimization CURLYX => CURLYM. */
3889 if ( OP(oscan) == CURLYX && data
3890 && !(data->flags & SF_HAS_PAR)
3891 && !(data->flags & SF_HAS_EVAL)
3892 && !deltanext /* atom is fixed width */
3893 && minnext != 0 /* CURLYM can't handle zero width */
3895 /* XXXX How to optimize if data == 0? */
3896 /* Optimize to a simpler form. */
3897 regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3901 while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3902 && (OP(nxt2) != WHILEM))
3904 OP(nxt2) = SUCCEED; /* Whas WHILEM */
3905 /* Need to optimize away parenths. */
3906 if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
3907 /* Set the parenth number. */
3908 regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
3910 oscan->flags = (U8)ARG(nxt);
3911 if (RExC_open_parens) {
3912 RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3913 RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
3915 OP(nxt1) = OPTIMIZED; /* was OPEN. */
3916 OP(nxt) = OPTIMIZED; /* was CLOSE. */
3919 OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3920 OP(nxt + 1) = OPTIMIZED; /* was count. */
3921 NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
3922 NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
3925 while ( nxt1 && (OP(nxt1) != WHILEM)) {
3926 regnode *nnxt = regnext(nxt1);
3928 if (reg_off_by_arg[OP(nxt1)])
3929 ARG_SET(nxt1, nxt2 - nxt1);
3930 else if (nxt2 - nxt1 < U16_MAX)
3931 NEXT_OFF(nxt1) = nxt2 - nxt1;
3933 OP(nxt) = NOTHING; /* Cannot beautify */
3938 /* Optimize again: */
3939 study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
3940 NULL, stopparen, recursed, NULL, 0,depth+1);
3945 else if ((OP(oscan) == CURLYX)
3946 && (flags & SCF_WHILEM_VISITED_POS)
3947 /* See the comment on a similar expression above.
3948 However, this time it's not a subexpression
3949 we care about, but the expression itself. */
3950 && (maxcount == REG_INFTY)
3951 && data && ++data->whilem_c < 16) {
3952 /* This stays as CURLYX, we can put the count/of pair. */
3953 /* Find WHILEM (as in regexec.c) */
3954 regnode *nxt = oscan + NEXT_OFF(oscan);
3956 if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
3958 PREVOPER(nxt)->flags = (U8)(data->whilem_c
3959 | (RExC_whilem_seen << 4)); /* On WHILEM */
3961 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
3963 if (flags & SCF_DO_SUBSTR) {
3964 SV *last_str = NULL;
3965 int counted = mincount != 0;
3967 if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
3968 #if defined(SPARC64_GCC_WORKAROUND)
3971 const char *s = NULL;
3974 if (pos_before >= data->last_start_min)
3977 b = data->last_start_min;
3980 s = SvPV_const(data->last_found, l);
3981 old = b - data->last_start_min;
3984 I32 b = pos_before >= data->last_start_min
3985 ? pos_before : data->last_start_min;
3987 const char * const s = SvPV_const(data->last_found, l);
3988 I32 old = b - data->last_start_min;
3992 old = utf8_hop((U8*)s, old) - (U8*)s;
3994 /* Get the added string: */
3995 last_str = newSVpvn_utf8(s + old, l, UTF);
3996 if (deltanext == 0 && pos_before == b) {
3997 /* What was added is a constant string */
3999 SvGROW(last_str, (mincount * l) + 1);
4000 repeatcpy(SvPVX(last_str) + l,
4001 SvPVX_const(last_str), l, mincount - 1);
4002 SvCUR_set(last_str, SvCUR(last_str) * mincount);
4003 /* Add additional parts. */
4004 SvCUR_set(data->last_found,
4005 SvCUR(data->last_found) - l);
4006 sv_catsv(data->last_found, last_str);
4008 SV * sv = data->last_found;
4010 SvUTF8(sv) && SvMAGICAL(sv) ?
4011 mg_find(sv, PERL_MAGIC_utf8) : NULL;
4012 if (mg && mg->mg_len >= 0)
4013 mg->mg_len += CHR_SVLEN(last_str) - l;
4015 data->last_end += l * (mincount - 1);
4018 /* start offset must point into the last copy */
4019 data->last_start_min += minnext * (mincount - 1);
4020 data->last_start_max += is_inf ? I32_MAX
4021 : (maxcount - 1) * (minnext + data->pos_delta);
4024 /* It is counted once already... */
4025 data->pos_min += minnext * (mincount - counted);
4026 data->pos_delta += - counted * deltanext +
4027 (minnext + deltanext) * maxcount - minnext * mincount;
4028 if (mincount != maxcount) {
4029 /* Cannot extend fixed substrings found inside
4031 SCAN_COMMIT(pRExC_state,data,minlenp);
4032 if (mincount && last_str) {
4033 SV * const sv = data->last_found;
4034 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4035 mg_find(sv, PERL_MAGIC_utf8) : NULL;
4039 sv_setsv(sv, last_str);
4040 data->last_end = data->pos_min;
4041 data->last_start_min =
4042 data->pos_min - CHR_SVLEN(last_str);
4043 data->last_start_max = is_inf
4045 : data->pos_min + data->pos_delta
4046 - CHR_SVLEN(last_str);
4048 data->longest = &(data->longest_float);
4050 SvREFCNT_dec(last_str);
4052 if (data && (fl & SF_HAS_EVAL))
4053 data->flags |= SF_HAS_EVAL;
4054 optimize_curly_tail:
4055 if (OP(oscan) != CURLYX) {
4056 while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
4058 NEXT_OFF(oscan) += NEXT_OFF(next);
4061 default: /* REF, ANYOFV, and CLUMP only? */
4062 if (flags & SCF_DO_SUBSTR) {
4063 SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
4064 data->longest = &(data->longest_float);
4066 is_inf = is_inf_internal = 1;
4067 if (flags & SCF_DO_STCLASS_OR)
4068 cl_anything(pRExC_state, data->start_class);
4069 flags &= ~SCF_DO_STCLASS;
4073 else if (OP(scan) == LNBREAK) {
4074 if (flags & SCF_DO_STCLASS) {
4076 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
4077 if (flags & SCF_DO_STCLASS_AND) {
4078 for (value = 0; value < 256; value++)
4079 if (!is_VERTWS_cp(value))
4080 ANYOF_BITMAP_CLEAR(data->start_class, value);
4083 for (value = 0; value < 256; value++)
4084 if (is_VERTWS_cp(value))
4085 ANYOF_BITMAP_SET(data->start_class, value);
4087 if (flags & SCF_DO_STCLASS_OR)
4088 cl_and(data->start_class, and_withp);
4089 flags &= ~SCF_DO_STCLASS;
4093 if (flags & SCF_DO_SUBSTR) {
4094 SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
4096 data->pos_delta += 1;
4097 data->longest = &(data->longest_float);
4100 else if (REGNODE_SIMPLE(OP(scan))) {
4103 if (flags & SCF_DO_SUBSTR) {
4104 SCAN_COMMIT(pRExC_state,data,minlenp);
4108 if (flags & SCF_DO_STCLASS) {
4109 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
4111 /* Some of the logic below assumes that switching
4112 locale on will only add false positives. */
4113 switch (PL_regkind[OP(scan)]) {
4117 /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
4118 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4119 cl_anything(pRExC_state, data->start_class);
4122 if (OP(scan) == SANY)
4124 if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
4125 value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
4126 || ANYOF_CLASS_TEST_ANY_SET(data->start_class));
4127 cl_anything(pRExC_state, data->start_class);
4129 if (flags & SCF_DO_STCLASS_AND || !value)
4130 ANYOF_BITMAP_CLEAR(data->start_class,'\n');
4133 if (flags & SCF_DO_STCLASS_AND)
4134 cl_and(data->start_class,
4135 (struct regnode_charclass_class*)scan);
4137 cl_or(pRExC_state, data->start_class,
4138 (struct regnode_charclass_class*)scan);
4141 if (flags & SCF_DO_STCLASS_AND) {
4142 if (!(data->start_class->flags & ANYOF_LOCALE)) {
4143 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
4144 if (OP(scan) == ALNUMU) {
4145 for (value = 0; value < 256; value++) {
4146 if (!isWORDCHAR_L1(value)) {
4147 ANYOF_BITMAP_CLEAR(data->start_class, value);
4151 for (value = 0; value < 256; value++) {
4152 if (!isALNUM(value)) {
4153 ANYOF_BITMAP_CLEAR(data->start_class, value);
4160 if (data->start_class->flags & ANYOF_LOCALE)
4161 ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
4163 /* Even if under locale, set the bits for non-locale
4164 * in case it isn't a true locale-node. This will
4165 * create false positives if it truly is locale */
4166 if (OP(scan) == ALNUMU) {
4167 for (value = 0; value < 256; value++) {
4168 if (isWORDCHAR_L1(value)) {
4169 ANYOF_BITMAP_SET(data->start_class, value);
4173 for (value = 0; value < 256; value++) {
4174 if (isALNUM(value)) {
4175 ANYOF_BITMAP_SET(data->start_class, value);
4182 if (flags & SCF_DO_STCLASS_AND) {
4183 if (!(data->start_class->flags & ANYOF_LOCALE)) {
4184 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
4185 if (OP(scan) == NALNUMU) {
4186 for (value = 0; value < 256; value++) {
4187 if (isWORDCHAR_L1(value)) {
4188 ANYOF_BITMAP_CLEAR(data->start_class, value);
4192 for (value = 0; value < 256; value++) {
4193 if (isALNUM(value)) {
4194 ANYOF_BITMAP_CLEAR(data->start_class, value);
4201 if (data->start_class->flags & ANYOF_LOCALE)
4202 ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
4204 /* Even if under locale, set the bits for non-locale in
4205 * case it isn't a true locale-node. This will create
4206 * false positives if it truly is locale */
4207 if (OP(scan) == NALNUMU) {
4208 for (value = 0; value < 256; value++) {
4209 if (! isWORDCHAR_L1(value)) {
4210 ANYOF_BITMAP_SET(data->start_class, value);
4214 for (value = 0; value < 256; value++) {
4215 if (! isALNUM(value)) {
4216 ANYOF_BITMAP_SET(data->start_class, value);
4223 if (flags & SCF_DO_STCLASS_AND) {
4224 if (!(data->start_class->flags & ANYOF_LOCALE)) {
4225 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
4226 if (OP(scan) == SPACEU) {
4227 for (value = 0; value < 256; value++) {
4228 if (!isSPACE_L1(value)) {
4229 ANYOF_BITMAP_CLEAR(data->start_class, value);
4233 for (value = 0; value < 256; value++) {
4234 if (!isSPACE(value)) {
4235 ANYOF_BITMAP_CLEAR(data->start_class, value);
4242 if (data->start_class->flags & ANYOF_LOCALE) {
4243 ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
4245 if (OP(scan) == SPACEU) {
4246 for (value = 0; value < 256; value++) {
4247 if (isSPACE_L1(value)) {
4248 ANYOF_BITMAP_SET(data->start_class, value);
4252 for (value = 0; value < 256; value++) {
4253 if (isSPACE(value)) {
4254 ANYOF_BITMAP_SET(data->start_class, value);
4261 if (flags & SCF_DO_STCLASS_AND) {
4262 if (!(data->start_class->flags & ANYOF_LOCALE)) {
4263 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
4264 if (OP(scan) == NSPACEU) {
4265 for (value = 0; value < 256; value++) {
4266 if (isSPACE_L1(value)) {
4267 ANYOF_BITMAP_CLEAR(data->start_class, value);
4271 for (value = 0; value < 256; value++) {
4272 if (isSPACE(value)) {
4273 ANYOF_BITMAP_CLEAR(data->start_class, value);
4280 if (data->start_class->flags & ANYOF_LOCALE)
4281 ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
4282 if (OP(scan) == NSPACEU) {
4283 for (value = 0; value < 256; value++) {
4284 if (!isSPACE_L1(value)) {
4285 ANYOF_BITMAP_SET(data->start_class, value);
4290 for (value = 0; value < 256; value++) {
4291 if (!isSPACE(value)) {
4292 ANYOF_BITMAP_SET(data->start_class, value);
4299 if (flags & SCF_DO_STCLASS_AND) {
4300 if (!(data->start_class->flags & ANYOF_LOCALE)) {
4301 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
4302 for (value = 0; value < 256; value++)
4303 if (!isDIGIT(value))
4304 ANYOF_BITMAP_CLEAR(data->start_class, value);
4308 if (data->start_class->flags & ANYOF_LOCALE)
4309 ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
4310 for (value = 0; value < 256; value++)
4312 ANYOF_BITMAP_SET(data->start_class, value);
4316 if (flags & SCF_DO_STCLASS_AND) {
4317 if (!(data->start_class->flags & ANYOF_LOCALE))
4318 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
4319 for (value = 0; value < 256; value++)
4321 ANYOF_BITMAP_CLEAR(data->start_class, value);
4324 if (data->start_class->flags & ANYOF_LOCALE)
4325 ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
4326 for (value = 0; value < 256; value++)
4327 if (!isDIGIT(value))
4328 ANYOF_BITMAP_SET(data->start_class, value);
4331 CASE_SYNST_FNC(VERTWS);
4332 CASE_SYNST_FNC(HORIZWS);
4335 if (flags & SCF_DO_STCLASS_OR)
4336 cl_and(data->start_class, and_withp);
4337 flags &= ~SCF_DO_STCLASS;
4340 else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
4341 data->flags |= (OP(scan) == MEOL
4345 else if ( PL_regkind[OP(scan)] == BRANCHJ
4346 /* Lookbehind, or need to calculate parens/evals/stclass: */
4347 && (scan->flags || data || (flags & SCF_DO_STCLASS))
4348 && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
4349 if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4350 || OP(scan) == UNLESSM )
4352 /* Negative Lookahead/lookbehind
4353 In this case we can't do fixed string optimisation.
4356 I32 deltanext, minnext, fake = 0;
4358 struct regnode_charclass_class intrnl;
4361 data_fake.flags = 0;
4363 data_fake.whilem_c = data->whilem_c;
4364 data_fake.last_closep = data->last_closep;
4367 data_fake.last_closep = &fake;
4368 data_fake.pos_delta = delta;
4369 if ( flags & SCF_DO_STCLASS && !scan->flags
4370 && OP(scan) == IFMATCH ) { /* Lookahead */
4371 cl_init(pRExC_state, &intrnl);
4372 data_fake.start_class = &intrnl;
4373 f |= SCF_DO_STCLASS_AND;
4375 if (flags & SCF_WHILEM_VISITED_POS)
4376 f |= SCF_WHILEM_VISITED_POS;
4377 next = regnext(scan);
4378 nscan = NEXTOPER(NEXTOPER(scan));
4379 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
4380 last, &data_fake, stopparen, recursed, NULL, f, depth+1);
4383 FAIL("Variable length lookbehind not implemented");
4385 else if (minnext > (I32)U8_MAX) {
4386 FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4388 scan->flags = (U8)minnext;
4391 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4393 if (data_fake.flags & SF_HAS_EVAL)
4394 data->flags |= SF_HAS_EVAL;
4395 data->whilem_c = data_fake.whilem_c;
4397 if (f & SCF_DO_STCLASS_AND) {
4398 if (flags & SCF_DO_STCLASS_OR) {
4399 /* OR before, AND after: ideally we would recurse with
4400 * data_fake to get the AND applied by study of the
4401 * remainder of the pattern, and then derecurse;
4402 * *** HACK *** for now just treat as "no information".
4403 * See [perl #56690].
4405 cl_init(pRExC_state, data->start_class);
4407 /* AND before and after: combine and continue */
4408 const int was = (data->start_class->flags & ANYOF_EOS);
4410 cl_and(data->start_class, &intrnl);
4412 data->start_class->flags |= ANYOF_EOS;
4416 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4418 /* Positive Lookahead/lookbehind
4419 In this case we can do fixed string optimisation,
4420 but we must be careful about it. Note in the case of
4421 lookbehind the positions will be offset by the minimum
4422 length of the pattern, something we won't know about
4423 until after the recurse.
4425 I32 deltanext, fake = 0;
4427 struct regnode_charclass_class intrnl;
4429 /* We use SAVEFREEPV so that when the full compile
4430 is finished perl will clean up the allocated
4431 minlens when it's all done. This way we don't
4432 have to worry about freeing them when we know
4433 they wont be used, which would be a pain.
4436 Newx( minnextp, 1, I32 );
4437 SAVEFREEPV(minnextp);
4440 StructCopy(data, &data_fake, scan_data_t);
4441 if ((flags & SCF_DO_SUBSTR) && data->last_found) {
4444 SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
4445 data_fake.last_found=newSVsv(data->last_found);
4449 data_fake.last_closep = &fake;
4450 data_fake.flags = 0;
4451 data_fake.pos_delta = delta;
4453 data_fake.flags |= SF_IS_INF;
4454 if ( flags & SCF_DO_STCLASS && !scan->flags
4455 && OP(scan) == IFMATCH ) { /* Lookahead */
4456 cl_init(pRExC_state, &intrnl);
4457 data_fake.start_class = &intrnl;
4458 f |= SCF_DO_STCLASS_AND;
4460 if (flags & SCF_WHILEM_VISITED_POS)
4461 f |= SCF_WHILEM_VISITED_POS;
4462 next = regnext(scan);
4463 nscan = NEXTOPER(NEXTOPER(scan));
4465 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext,
4466 last, &data_fake, stopparen, recursed, NULL, f,depth+1);
4469 FAIL("Variable length lookbehind not implemented");
4471 else if (*minnextp > (I32)U8_MAX) {
4472 FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4474 scan->flags = (U8)*minnextp;
4479 if (f & SCF_DO_STCLASS_AND) {
4480 const int was = (data->start_class->flags & ANYOF_EOS);
4482 cl_and(data->start_class, &intrnl);
4484 data->start_class->flags |= ANYOF_EOS;
4487 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4489 if (data_fake.flags & SF_HAS_EVAL)
4490 data->flags |= SF_HAS_EVAL;
4491 data->whilem_c = data_fake.whilem_c;
4492 if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
4493 if (RExC_rx->minlen<*minnextp)
4494 RExC_rx->minlen=*minnextp;
4495 SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
4496 SvREFCNT_dec(data_fake.last_found);
4498 if ( data_fake.minlen_fixed != minlenp )
4500 data->offset_fixed= data_fake.offset_fixed;
4501 data->minlen_fixed= data_fake.minlen_fixed;
4502 data->lookbehind_fixed+= scan->flags;
4504 if ( data_fake.minlen_float != minlenp )
4506 data->minlen_float= data_fake.minlen_float;
4507 data->offset_float_min=data_fake.offset_float_min;
4508 data->offset_float_max=data_fake.offset_float_max;
4509 data->lookbehind_float+= scan->flags;
4518 else if (OP(scan) == OPEN) {
4519 if (stopparen != (I32)ARG(scan))
4522 else if (OP(scan) == CLOSE) {
4523 if (stopparen == (I32)ARG(scan)) {
4526 if ((I32)ARG(scan) == is_par) {
4527 next = regnext(scan);
4529 if ( next && (OP(next) != WHILEM) && next < last)
4530 is_par = 0; /* Disable optimization */
4533 *(data->last_closep) = ARG(scan);
4535 else if (OP(scan) == EVAL) {
4537 data->flags |= SF_HAS_EVAL;
4539 else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
4540 if (flags & SCF_DO_SUBSTR) {
4541 SCAN_COMMIT(pRExC_state,data,minlenp);
4542 flags &= ~SCF_DO_SUBSTR;
4544 if (data && OP(scan)==ACCEPT) {
4545 data->flags |= SCF_SEEN_ACCEPT;
4550 else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
4552 if (flags & SCF_DO_SUBSTR) {
4553 SCAN_COMMIT(pRExC_state,data,minlenp);
4554 data->longest = &(data->longest_float);
4556 is_inf = is_inf_internal = 1;
4557 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4558 cl_anything(pRExC_state, data->start_class);
4559 flags &= ~SCF_DO_STCLASS;
4561 else if (OP(scan) == GPOS) {
4562 if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
4563 !(delta || is_inf || (data && data->pos_delta)))
4565 if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
4566 RExC_rx->extflags |= RXf_ANCH_GPOS;
4567 if (RExC_rx->gofs < (U32)min)
4568 RExC_rx->gofs = min;
4570 RExC_rx->extflags |= RXf_GPOS_FLOAT;
4574 #ifdef TRIE_STUDY_OPT
4575 #ifdef FULL_TRIE_STUDY
4576 else if (PL_regkind[OP(scan)] == TRIE) {
4577 /* NOTE - There is similar code to this block above for handling
4578 BRANCH nodes on the initial study. If you change stuff here
4580 regnode *trie_node= scan;
4581 regnode *tail= regnext(scan);
4582 reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4583 I32 max1 = 0, min1 = I32_MAX;
4584 struct regnode_charclass_class accum;
4586 if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
4587 SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
4588 if (flags & SCF_DO_STCLASS)
4589 cl_init_zero(pRExC_state, &accum);
4595 const regnode *nextbranch= NULL;
4598 for ( word=1 ; word <= trie->wordcount ; word++)
4600 I32 deltanext=0, minnext=0, f = 0, fake;
4601 struct regnode_charclass_class this_class;
4603 data_fake.flags = 0;
4605 data_fake.whilem_c = data->whilem_c;
4606 data_fake.last_closep = data->last_closep;
4609 data_fake.last_closep = &fake;
4610 data_fake.pos_delta = delta;
4611 if (flags & SCF_DO_STCLASS) {
4612 cl_init(pRExC_state, &this_class);
4613 data_fake.start_class = &this_class;
4614 f = SCF_DO_STCLASS_AND;
4616 if (flags & SCF_WHILEM_VISITED_POS)
4617 f |= SCF_WHILEM_VISITED_POS;
4619 if (trie->jump[word]) {
4621 nextbranch = trie_node + trie->jump[0];
4622 scan= trie_node + trie->jump[word];
4623 /* We go from the jump point to the branch that follows
4624 it. Note this means we need the vestigal unused branches
4625 even though they arent otherwise used.
4627 minnext = study_chunk(pRExC_state, &scan, minlenp,
4628 &deltanext, (regnode *)nextbranch, &data_fake,
4629 stopparen, recursed, NULL, f,depth+1);
4631 if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
4632 nextbranch= regnext((regnode*)nextbranch);
4634 if (min1 > (I32)(minnext + trie->minlen))
4635 min1 = minnext + trie->minlen;
4636 if (max1 < (I32)(minnext + deltanext + trie->maxlen))
4637 max1 = minnext + deltanext + trie->maxlen;
4638 if (deltanext == I32_MAX)
4639 is_inf = is_inf_internal = 1;
4641 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4643 if (data_fake.flags & SCF_SEEN_ACCEPT) {
4644 if ( stopmin > min + min1)
4645 stopmin = min + min1;
4646 flags &= ~SCF_DO_SUBSTR;
4648 data->flags |= SCF_SEEN_ACCEPT;
4651 if (data_fake.flags & SF_HAS_EVAL)
4652 data->flags |= SF_HAS_EVAL;
4653 data->whilem_c = data_fake.whilem_c;
4655 if (flags & SCF_DO_STCLASS)
4656 cl_or(pRExC_state, &accum, &this_class);
4659 if (flags & SCF_DO_SUBSTR) {
4660 data->pos_min += min1;
4661 data->pos_delta += max1 - min1;
4662 if (max1 != min1 || is_inf)
4663 data->longest = &(data->longest_float);
4666 delta += max1 - min1;
4667 if (flags & SCF_DO_STCLASS_OR) {
4668 cl_or(pRExC_state, data->start_class, &accum);
4670 cl_and(data->start_class, and_withp);
4671 flags &= ~SCF_DO_STCLASS;
4674 else if (flags & SCF_DO_STCLASS_AND) {
4676 cl_and(data->start_class, &accum);
4677 flags &= ~SCF_DO_STCLASS;
4680 /* Switch to OR mode: cache the old value of
4681 * data->start_class */
4683 StructCopy(data->start_class, and_withp,
4684 struct regnode_charclass_class);
4685 flags &= ~SCF_DO_STCLASS_AND;
4686 StructCopy(&accum, data->start_class,
4687 struct regnode_charclass_class);
4688 flags |= SCF_DO_STCLASS_OR;
4689 data->start_class->flags |= ANYOF_EOS;
4696 else if (PL_regkind[OP(scan)] == TRIE) {
4697 reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4700 min += trie->minlen;
4701 delta += (trie->maxlen - trie->minlen);
4702 flags &= ~SCF_DO_STCLASS; /* xxx */
4703 if (flags & SCF_DO_SUBSTR) {
4704 SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
4705 data->pos_min += trie->minlen;
4706 data->pos_delta += (trie->maxlen - trie->minlen);
4707 if (trie->maxlen != trie->minlen)
4708 data->longest = &(data->longest_float);
4710 if (trie->jump) /* no more substrings -- for now /grr*/
4711 flags &= ~SCF_DO_SUBSTR;
4713 #endif /* old or new */
4714 #endif /* TRIE_STUDY_OPT */
4716 /* Else: zero-length, ignore. */
4717 scan = regnext(scan);
4722 stopparen = frame->stop;
4723 frame = frame->prev;
4724 goto fake_study_recurse;
4729 DEBUG_STUDYDATA("pre-fin:",data,depth);
4732 *deltap = is_inf_internal ? I32_MAX : delta;
4733 if (flags & SCF_DO_SUBSTR && is_inf)
4734 data->pos_delta = I32_MAX - data->pos_min;
4735 if (is_par > (I32)U8_MAX)
4737 if (is_par && pars==1 && data) {
4738 data->flags |= SF_IN_PAR;
4739 data->flags &= ~SF_HAS_PAR;
4741 else if (pars && data) {
4742 data->flags |= SF_HAS_PAR;
4743 data->flags &= ~SF_IN_PAR;
4745 if (flags & SCF_DO_STCLASS_OR)
4746 cl_and(data->start_class, and_withp);
4747 if (flags & SCF_TRIE_RESTUDY)
4748 data->flags |= SCF_TRIE_RESTUDY;
4750 DEBUG_STUDYDATA("post-fin:",data,depth);
4752 return min < stopmin ? min : stopmin;
4756 S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s)
4758 U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
4760 PERL_ARGS_ASSERT_ADD_DATA;
4762 Renewc(RExC_rxi->data,
4763 sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
4764 char, struct reg_data);
4766 Renew(RExC_rxi->data->what, count + n, U8);
4768 Newx(RExC_rxi->data->what, n, U8);
4769 RExC_rxi->data->count = count + n;
4770 Copy(s, RExC_rxi->data->what + count, n, U8);
4774 /*XXX: todo make this not included in a non debugging perl */
4775 #ifndef PERL_IN_XSUB_RE
4777 Perl_reginitcolors(pTHX)
4780 const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
4782 char *t = savepv(s);
4786 t = strchr(t, '\t');
4792 PL_colors[i] = t = (char *)"";
4797 PL_colors[i++] = (char *)"";
4804 #ifdef TRIE_STUDY_OPT
4805 #define CHECK_RESTUDY_GOTO \
4807 (data.flags & SCF_TRIE_RESTUDY) \
4811 #define CHECK_RESTUDY_GOTO
4815 - pregcomp - compile a regular expression into internal code
4817 * We can't allocate space until we know how big the compiled form will be,
4818 * but we can't compile it (and thus know how big it is) until we've got a
4819 * place to put the code. So we cheat: we compile it twice, once with code
4820 * generation turned off and size counting turned on, and once "for real".
4821 * This also means that we don't allocate space until we are sure that the
4822 * thing really will compile successfully, and we never have to move the
4823 * code and thus invalidate pointers into it. (Note that it has to be in
4824 * one piece because free() must be able to free it all.) [NB: not true in perl]
4826 * Beware that the optimization-preparation code in here knows about some
4827 * of the structure of the compiled regexp. [I'll say.]
4832 #ifndef PERL_IN_XSUB_RE
4833 #define RE_ENGINE_PTR &reh_regexp_engine
4835 extern const struct regexp_engine my_reg_engine;
4836 #define RE_ENGINE_PTR &my_reg_engine
4839 #ifndef PERL_IN_XSUB_RE
4841 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
4844 HV * const table = GvHV(PL_hintgv);
4846 PERL_ARGS_ASSERT_PREGCOMP;
4848 /* Dispatch a request to compile a regexp to correct
4851 SV **ptr= hv_fetchs(table, "regcomp", FALSE);
4852 GET_RE_DEBUG_FLAGS_DECL;
4853 if (ptr && SvIOK(*ptr) && SvIV(*ptr)) {
4854 const regexp_engine *eng=INT2PTR(regexp_engine*,SvIV(*ptr));
4856 PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
4859 return CALLREGCOMP_ENG(eng, pattern, flags);
4862 return Perl_re_compile(aTHX_ pattern, flags);
4867 Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
4872 register regexp_internal *ri;
4881 /* these are all flags - maybe they should be turned
4882 * into a single int with different bit masks */
4883 I32 sawlookahead = 0;
4886 bool used_setjump = FALSE;
4887 regex_charset initial_charset = get_regex_charset(orig_pm_flags);
4892 RExC_state_t RExC_state;
4893 RExC_state_t * const pRExC_state = &RExC_state;
4894 #ifdef TRIE_STUDY_OPT
4896 RExC_state_t copyRExC_state;
4898 GET_RE_DEBUG_FLAGS_DECL;
4900 PERL_ARGS_ASSERT_RE_COMPILE;
4902 DEBUG_r(if (!PL_colorset) reginitcolors());
4904 #ifndef PERL_IN_XSUB_RE
4905 /* Initialize these here instead of as-needed, as is quick and avoids
4906 * having to test them each time otherwise */
4907 if (! PL_AboveLatin1) {
4908 PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
4909 PL_ASCII = _new_invlist_C_array(ASCII_invlist);
4910 PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
4912 PL_L1PosixAlnum = _new_invlist_C_array(L1PosixAlnum_invlist);
4913 PL_PosixAlnum = _new_invlist_C_array(PosixAlnum_invlist);
4915 PL_L1PosixAlpha = _new_invlist_C_array(L1PosixAlpha_invlist);
4916 PL_PosixAlpha = _new_invlist_C_array(PosixAlpha_invlist);
4918 PL_PosixBlank = _new_invlist_C_array(PosixBlank_invlist);
4919 PL_XPosixBlank = _new_invlist_C_array(XPosixBlank_invlist);
4921 PL_L1Cased = _new_invlist_C_array(L1Cased_invlist);
4923 PL_PosixCntrl = _new_invlist_C_array(PosixCntrl_invlist);
4924 PL_XPosixCntrl = _new_invlist_C_array(XPosixCntrl_invlist);
4926 PL_PosixDigit = _new_invlist_C_array(PosixDigit_invlist);
4928 PL_L1PosixGraph = _new_invlist_C_array(L1PosixGraph_invlist);
4929 PL_PosixGraph = _new_invlist_C_array(PosixGraph_invlist);
4931 PL_L1PosixAlnum = _new_invlist_C_array(L1PosixAlnum_invlist);
4932 PL_PosixAlnum = _new_invlist_C_array(PosixAlnum_invlist);
4934 PL_L1PosixLower = _new_invlist_C_array(L1PosixLower_invlist);
4935 PL_PosixLower = _new_invlist_C_array(PosixLower_invlist);
4937 PL_L1PosixPrint = _new_invlist_C_array(L1PosixPrint_invlist);
4938 PL_PosixPrint = _new_invlist_C_array(PosixPrint_invlist);
4940 PL_L1PosixPunct = _new_invlist_C_array(L1PosixPunct_invlist);
4941 PL_PosixPunct = _new_invlist_C_array(PosixPunct_invlist);
4943 PL_PerlSpace = _new_invlist_C_array(PerlSpace_invlist);
4944 PL_XPerlSpace = _new_invlist_C_array(XPerlSpace_invlist);
4946 PL_PosixSpace = _new_invlist_C_array(PosixSpace_invlist);
4947 PL_XPosixSpace = _new_invlist_C_array(XPosixSpace_invlist);
4949 PL_L1PosixUpper = _new_invlist_C_array(L1PosixUpper_invlist);
4950 PL_PosixUpper = _new_invlist_C_array(PosixUpper_invlist);
4952 PL_VertSpace = _new_invlist_C_array(VertSpace_invlist);
4954 PL_PosixWord = _new_invlist_C_array(PosixWord_invlist);
4955 PL_L1PosixWord = _new_invlist_C_array(L1PosixWord_invlist);
4957 PL_PosixXDigit = _new_invlist_C_array(PosixXDigit_invlist);
4958 PL_XPosixXDigit = _new_invlist_C_array(XPosixXDigit_invlist);
4962 exp = SvPV(pattern, plen);
4964 if (plen == 0) { /* ignore the utf8ness if the pattern is 0 length */
4965 RExC_utf8 = RExC_orig_utf8 = 0;
4968 RExC_utf8 = RExC_orig_utf8 = SvUTF8(pattern);
4970 RExC_uni_semantics = 0;
4971 RExC_contains_locale = 0;
4973 /****************** LONG JUMP TARGET HERE***********************/
4974 /* Longjmp back to here if have to switch in midstream to utf8 */
4975 if (! RExC_orig_utf8) {
4976 JMPENV_PUSH(jump_ret);
4977 used_setjump = TRUE;
4980 if (jump_ret == 0) { /* First time through */
4984 SV *dsv= sv_newmortal();
4985 RE_PV_QUOTED_DECL(s, RExC_utf8,
4986 dsv, exp, plen, 60);
4987 PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
4988 PL_colors[4],PL_colors[5],s);
4991 else { /* longjumped back */
4994 /* If the cause for the longjmp was other than changing to utf8, pop
4995 * our own setjmp, and longjmp to the correct handler */
4996 if (jump_ret != UTF8_LONGJMP) {
4998 JMPENV_JUMP(jump_ret);
5003 /* It's possible to write a regexp in ascii that represents Unicode
5004 codepoints outside of the byte range, such as via \x{100}. If we
5005 detect such a sequence we have to convert the entire pattern to utf8
5006 and then recompile, as our sizing calculation will have been based
5007 on 1 byte == 1 character, but we will need to use utf8 to encode
5008 at least some part of the pattern, and therefore must convert the whole
5011 DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
5012 "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
5013 exp = (char*)Perl_bytes_to_utf8(aTHX_
5014 (U8*)SvPV_nomg(pattern, plen),
5017 RExC_orig_utf8 = RExC_utf8 = 1;
5021 #ifdef TRIE_STUDY_OPT
5025 pm_flags = orig_pm_flags;
5027 if (initial_charset == REGEX_LOCALE_CHARSET) {
5028 RExC_contains_locale = 1;
5030 else if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
5032 /* Set to use unicode semantics if the pattern is in utf8 and has the
5033 * 'depends' charset specified, as it means unicode when utf8 */
5034 set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
5038 RExC_flags = pm_flags;
5042 RExC_in_lookbehind = 0;
5043 RExC_seen_zerolen = *exp == '^' ? -1 : 0;
5044 RExC_seen_evals = 0;
5046 RExC_override_recoding = 0;
5048 /* First pass: determine size, legality. */
5056 RExC_emit = &PL_regdummy;
5057 RExC_whilem_seen = 0;
5058 RExC_open_parens = NULL;
5059 RExC_close_parens = NULL;
5061 RExC_paren_names = NULL;
5063 RExC_paren_name_list = NULL;
5065 RExC_recurse = NULL;
5066 RExC_recurse_count = 0;
5068 #if 0 /* REGC() is (currently) a NOP at the first pass.
5069 * Clever compilers notice this and complain. --jhi */
5070 REGC((U8)REG_MAGIC, (char*)RExC_emit);
5073 PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n");
5075 RExC_lastparse=NULL;
5077 if (reg(pRExC_state, 0, &flags,1) == NULL) {
5078 RExC_precomp = NULL;
5082 /* Here, finished first pass. Get rid of any added setjmp */
5088 PerlIO_printf(Perl_debug_log,
5089 "Required size %"IVdf" nodes\n"
5090 "Starting second pass (creation)\n",
5093 RExC_lastparse=NULL;
5096 /* The first pass could have found things that force Unicode semantics */
5097 if ((RExC_utf8 || RExC_uni_semantics)
5098 && get_regex_charset(pm_flags) == REGEX_DEPENDS_CHARSET)
5100 set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
5103 /* Small enough for pointer-storage convention?
5104 If extralen==0, this means that we will not need long jumps. */
5105 if (RExC_size >= 0x10000L && RExC_extralen)
5106 RExC_size += RExC_extralen;
5109 if (RExC_whilem_seen > 15)
5110 RExC_whilem_seen = 15;
5112 /* Allocate space and zero-initialize. Note, the two step process
5113 of zeroing when in debug mode, thus anything assigned has to
5114 happen after that */
5115 rx = (REGEXP*) newSV_type(SVt_REGEXP);
5116 r = (struct regexp*)SvANY(rx);
5117 Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
5118 char, regexp_internal);
5119 if ( r == NULL || ri == NULL )
5120 FAIL("Regexp out of space");
5122 /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
5123 Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
5125 /* bulk initialize base fields with 0. */
5126 Zero(ri, sizeof(regexp_internal), char);
5129 /* non-zero initialization begins here */
5131 r->engine= RE_ENGINE_PTR;
5132 r->extflags = pm_flags;
5134 bool has_p = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
5135 bool has_charset = (get_regex_charset(r->extflags) != REGEX_DEPENDS_CHARSET);
5137 /* The caret is output if there are any defaults: if not all the STD
5138 * flags are set, or if no character set specifier is needed */
5140 (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
5142 bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT);
5143 U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
5144 >> RXf_PMf_STD_PMMOD_SHIFT);
5145 const char *fptr = STD_PAT_MODS; /*"msix"*/
5147 /* Allocate for the worst case, which is all the std flags are turned
5148 * on. If more precision is desired, we could do a population count of
5149 * the flags set. This could be done with a small lookup table, or by
5150 * shifting, masking and adding, or even, when available, assembly
5151 * language for a machine-language population count.
5152 * We never output a minus, as all those are defaults, so are
5153 * covered by the caret */
5154 const STRLEN wraplen = plen + has_p + has_runon
5155 + has_default /* If needs a caret */
5157 /* If needs a character set specifier */
5158 + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
5159 + (sizeof(STD_PAT_MODS) - 1)
5160 + (sizeof("(?:)") - 1);
5162 p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
5164 SvFLAGS(rx) |= SvUTF8(pattern);
5167 /* If a default, cover it using the caret */
5169 *p++= DEFAULT_PAT_MOD;
5173 const char* const name = get_regex_charset_name(r->extflags, &len);
5174 Copy(name, p, len, char);
5178 *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
5181 while((ch = *fptr++)) {
5189 Copy(RExC_precomp, p, plen, char);
5190 assert ((RX_WRAPPED(rx) - p) < 16);
5191 r->pre_prefix = p - RX_WRAPPED(rx);
5197 SvCUR_set(rx, p - SvPVX_const(rx));
5201 r->nparens = RExC_npar - 1; /* set early to validate backrefs */
5203 if (RExC_seen & REG_SEEN_RECURSE) {
5204 Newxz(RExC_open_parens, RExC_npar,regnode *);
5205 SAVEFREEPV(RExC_open_parens);
5206 Newxz(RExC_close_parens,RExC_npar,regnode *);
5207 SAVEFREEPV(RExC_close_parens);
5210 /* Useful during FAIL. */
5211 #ifdef RE_TRACK_PATTERN_OFFSETS
5212 Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
5213 DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
5214 "%s %"UVuf" bytes for offset annotations.\n",
5215 ri->u.offsets ? "Got" : "Couldn't get",
5216 (UV)((2*RExC_size+1) * sizeof(U32))));
5218 SetProgLen(ri,RExC_size);
5222 REH_CALL_COMP_BEGIN_HOOK(pRExC_state->rx);
5224 /* Second pass: emit code. */
5225 RExC_flags = pm_flags; /* don't let top level (?i) bleed */
5230 RExC_emit_start = ri->program;
5231 RExC_emit = ri->program;
5232 RExC_emit_bound = ri->program + RExC_size + 1;
5234 /* Store the count of eval-groups for security checks: */
5235 RExC_rx->seen_evals = RExC_seen_evals;
5236 REGC((U8)REG_MAGIC, (char*) RExC_emit++);
5237 if (reg(pRExC_state, 0, &flags,1) == NULL) {
5241 /* XXXX To minimize changes to RE engine we always allocate
5242 3-units-long substrs field. */
5243 Newx(r->substrs, 1, struct reg_substr_data);
5244 if (RExC_recurse_count) {
5245 Newxz(RExC_recurse,RExC_recurse_count,regnode *);
5246 SAVEFREEPV(RExC_recurse);
5250 r->minlen = minlen = sawlookahead = sawplus = sawopen = 0;
5251 Zero(r->substrs, 1, struct reg_substr_data);
5253 #ifdef TRIE_STUDY_OPT
5255 StructCopy(&zero_scan_data, &data, scan_data_t);
5256 copyRExC_state = RExC_state;
5259 DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
5261 RExC_state = copyRExC_state;
5262 if (seen & REG_TOP_LEVEL_BRANCHES)
5263 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
5265 RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
5266 if (data.last_found) {
5267 SvREFCNT_dec(data.longest_fixed);
5268 SvREFCNT_dec(data.longest_float);
5269 SvREFCNT_dec(data.last_found);
5271 StructCopy(&zero_scan_data, &data, scan_data_t);
5274 StructCopy(&zero_scan_data, &data, scan_data_t);
5277 /* Dig out information for optimizations. */
5278 r->extflags = RExC_flags; /* was pm_op */
5279 /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
5282 SvUTF8_on(rx); /* Unicode in it? */
5283 ri->regstclass = NULL;
5284 if (RExC_naughty >= 10) /* Probably an expensive pattern. */
5285 r->intflags |= PREGf_NAUGHTY;
5286 scan = ri->program + 1; /* First BRANCH. */
5288 /* testing for BRANCH here tells us whether there is "must appear"
5289 data in the pattern. If there is then we can use it for optimisations */
5290 if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /* Only one top-level choice. */
5292 STRLEN longest_float_length, longest_fixed_length;
5293 struct regnode_charclass_class ch_class; /* pointed to by data */
5295 I32 last_close = 0; /* pointed to by data */
5296 regnode *first= scan;
5297 regnode *first_next= regnext(first);
5299 * Skip introductions and multiplicators >= 1
5300 * so that we can extract the 'meat' of the pattern that must
5301 * match in the large if() sequence following.
5302 * NOTE that EXACT is NOT covered here, as it is normally
5303 * picked up by the optimiser separately.
5305 * This is unfortunate as the optimiser isnt handling lookahead
5306 * properly currently.
5309 while ((OP(first) == OPEN && (sawopen = 1)) ||
5310 /* An OR of *one* alternative - should not happen now. */
5311 (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
5312 /* for now we can't handle lookbehind IFMATCH*/
5313 (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
5314 (OP(first) == PLUS) ||
5315 (OP(first) == MINMOD) ||
5316 /* An {n,m} with n>0 */
5317 (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
5318 (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
5321 * the only op that could be a regnode is PLUS, all the rest
5322 * will be regnode_1 or regnode_2.
5325 if (OP(first) == PLUS)
5328 first += regarglen[OP(first)];
5330 first = NEXTOPER(first);
5331 first_next= regnext(first);
5334 /* Starting-point info. */
5336 DEBUG_PEEP("first:",first,0);
5337 /* Ignore EXACT as we deal with it later. */
5338 if (PL_regkind[OP(first)] == EXACT) {
5339 if (OP(first) == EXACT)
5340 NOOP; /* Empty, get anchored substr later. */
5342 ri->regstclass = first;
5345 else if (PL_regkind[OP(first)] == TRIE &&
5346 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0)
5349 /* this can happen only on restudy */
5350 if ( OP(first) == TRIE ) {
5351 struct regnode_1 *trieop = (struct regnode_1 *)
5352 PerlMemShared_calloc(1, sizeof(struct regnode_1));
5353 StructCopy(first,trieop,struct regnode_1);
5354 trie_op=(regnode *)trieop;
5356 struct regnode_charclass *trieop = (struct regnode_charclass *)
5357 PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
5358 StructCopy(first,trieop,struct regnode_charclass);
5359 trie_op=(regnode *)trieop;
5362 make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
5363 ri->regstclass = trie_op;
5366 else if (REGNODE_SIMPLE(OP(first)))
5367 ri->regstclass = first;
5368 else if (PL_regkind[OP(first)] == BOUND ||
5369 PL_regkind[OP(first)] == NBOUND)
5370 ri->regstclass = first;
5371 else if (PL_regkind[OP(first)] == BOL) {
5372 r->extflags |= (OP(first) == MBOL
5374 : (OP(first) == SBOL
5377 first = NEXTOPER(first);
5380 else if (OP(first) == GPOS) {
5381 r->extflags |= RXf_ANCH_GPOS;
5382 first = NEXTOPER(first);
5385 else if ((!sawopen || !RExC_sawback) &&
5386 (OP(first) == STAR &&
5387 PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
5388 !(r->extflags & RXf_ANCH) && !(RExC_seen & REG_SEEN_EVAL))
5390 /* turn .* into ^.* with an implied $*=1 */
5392 (OP(NEXTOPER(first)) == REG_ANY)
5395 r->extflags |= type;
5396 r->intflags |= PREGf_IMPLICIT;
5397 first = NEXTOPER(first);
5400 if (sawplus && !sawlookahead && (!sawopen || !RExC_sawback)
5401 && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
5402 /* x+ must match at the 1st pos of run of x's */
5403 r->intflags |= PREGf_SKIP;
5405 /* Scan is after the zeroth branch, first is atomic matcher. */
5406 #ifdef TRIE_STUDY_OPT
5409 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
5410 (IV)(first - scan + 1))
5414 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
5415 (IV)(first - scan + 1))
5421 * If there's something expensive in the r.e., find the
5422 * longest literal string that must appear and make it the
5423 * regmust. Resolve ties in favor of later strings, since
5424 * the regstart check works with the beginning of the r.e.
5425 * and avoiding duplication strengthens checking. Not a
5426 * strong reason, but sufficient in the absence of others.
5427 * [Now we resolve ties in favor of the earlier string if
5428 * it happens that c_offset_min has been invalidated, since the
5429 * earlier string may buy us something the later one won't.]
5432 data.longest_fixed = newSVpvs("");
5433 data.longest_float = newSVpvs("");
5434 data.last_found = newSVpvs("");
5435 data.longest = &(data.longest_fixed);
5437 if (!ri->regstclass) {
5438 cl_init(pRExC_state, &ch_class);
5439 data.start_class = &ch_class;
5440 stclass_flag = SCF_DO_STCLASS_AND;
5441 } else /* XXXX Check for BOUND? */
5443 data.last_closep = &last_close;
5445 minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
5446 &data, -1, NULL, NULL,
5447 SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
5453 if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
5454 && data.last_start_min == 0 && data.last_end > 0
5455 && !RExC_seen_zerolen
5456 && !(RExC_seen & REG_SEEN_VERBARG)
5457 && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
5458 r->extflags |= RXf_CHECK_ALL;
5459 scan_commit(pRExC_state, &data,&minlen,0);
5460 SvREFCNT_dec(data.last_found);
5462 /* Note that code very similar to this but for anchored string
5463 follows immediately below, changes may need to be made to both.
5466 longest_float_length = CHR_SVLEN(data.longest_float);
5467 if (longest_float_length
5468 || (data.flags & SF_FL_BEFORE_EOL
5469 && (!(data.flags & SF_FL_BEFORE_MEOL)
5470 || (RExC_flags & RXf_PMf_MULTILINE))))
5474 /* See comments for join_exact for why REG_SEEN_EXACTF_SHARP_S */
5475 if ((RExC_seen & REG_SEEN_EXACTF_SHARP_S)
5476 || (SvCUR(data.longest_fixed) /* ok to leave SvCUR */
5477 && data.offset_fixed == data.offset_float_min
5478 && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
5479 goto remove_float; /* As in (a)+. */
5481 /* copy the information about the longest float from the reg_scan_data
5482 over to the program. */
5483 if (SvUTF8(data.longest_float)) {
5484 r->float_utf8 = data.longest_float;
5485 r->float_substr = NULL;
5487 r->float_substr = data.longest_float;
5488 r->float_utf8 = NULL;
5490 /* float_end_shift is how many chars that must be matched that
5491 follow this item. We calculate it ahead of time as once the
5492 lookbehind offset is added in we lose the ability to correctly
5494 ml = data.minlen_float ? *(data.minlen_float)
5495 : (I32)longest_float_length;
5496 r->float_end_shift = ml - data.offset_float_min
5497 - longest_float_length + (SvTAIL(data.longest_float) != 0)
5498 + data.lookbehind_float;
5499 r->float_min_offset = data.offset_float_min - data.lookbehind_float;
5500 r->float_max_offset = data.offset_float_max;
5501 if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
5502 r->float_max_offset -= data.lookbehind_float;
5504 t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
5505 && (!(data.flags & SF_FL_BEFORE_MEOL)
5506 || (RExC_flags & RXf_PMf_MULTILINE)));
5507 fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
5511 r->float_substr = r->float_utf8 = NULL;
5512 SvREFCNT_dec(data.longest_float);
5513 longest_float_length = 0;
5516 /* Note that code very similar to this but for floating string
5517 is immediately above, changes may need to be made to both.
5520 longest_fixed_length = CHR_SVLEN(data.longest_fixed);
5522 /* See comments for join_exact for why REG_SEEN_EXACTF_SHARP_S */
5523 if (! (RExC_seen & REG_SEEN_EXACTF_SHARP_S)
5524 && (longest_fixed_length
5525 || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
5526 && (!(data.flags & SF_FIX_BEFORE_MEOL)
5527 || (RExC_flags & RXf_PMf_MULTILINE)))) )
5531 /* copy the information about the longest fixed
5532 from the reg_scan_data over to the program. */
5533 if (SvUTF8(data.longest_fixed)) {
5534 r->anchored_utf8 = data.longest_fixed;
5535 r->anchored_substr = NULL;
5537 r->anchored_substr = data.longest_fixed;
5538 r->anchored_utf8 = NULL;
5540 /* fixed_end_shift is how many chars that must be matched that
5541 follow this item. We calculate it ahead of time as once the
5542 lookbehind offset is added in we lose the ability to correctly
5544 ml = data.minlen_fixed ? *(data.minlen_fixed)
5545 : (I32)longest_fixed_length;
5546 r->anchored_end_shift = ml - data.offset_fixed
5547 - longest_fixed_length + (SvTAIL(data.longest_fixed) != 0)
5548 + data.lookbehind_fixed;
5549 r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
5551 t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
5552 && (!(data.flags & SF_FIX_BEFORE_MEOL)
5553 || (RExC_flags & RXf_PMf_MULTILINE)));
5554 fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
5557 r->anchored_substr = r->anchored_utf8 = NULL;
5558 SvREFCNT_dec(data.longest_fixed);
5559 longest_fixed_length = 0;
5562 && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
5563 ri->regstclass = NULL;
5565 if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
5567 && !(data.start_class->flags & ANYOF_EOS)
5568 && !cl_is_anything(data.start_class))
5570 const U32 n = add_data(pRExC_state, 1, "f");
5571 data.start_class->flags |= ANYOF_IS_SYNTHETIC;
5573 Newx(RExC_rxi->data->data[n], 1,
5574 struct regnode_charclass_class);
5575 StructCopy(data.start_class,
5576 (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5577 struct regnode_charclass_class);
5578 ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5579 r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5580 DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
5581 regprop(r, sv, (regnode*)data.start_class);
5582 PerlIO_printf(Perl_debug_log,
5583 "synthetic stclass \"%s\".\n",
5584 SvPVX_const(sv));});
5587 /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
5588 if (longest_fixed_length > longest_float_length) {
5589 r->check_end_shift = r->anchored_end_shift;
5590 r->check_substr = r->anchored_substr;
5591 r->check_utf8 = r->anchored_utf8;
5592 r->check_offset_min = r->check_offset_max = r->anchored_offset;
5593 if (r->extflags & RXf_ANCH_SINGLE)
5594 r->extflags |= RXf_NOSCAN;
5597 r->check_end_shift = r->float_end_shift;
5598 r->check_substr = r->float_substr;
5599 r->check_utf8 = r->float_utf8;
5600 r->check_offset_min = r->float_min_offset;
5601 r->check_offset_max = r->float_max_offset;
5603 /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
5604 This should be changed ASAP! */
5605 if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
5606 r->extflags |= RXf_USE_INTUIT;
5607 if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
5608 r->extflags |= RXf_INTUIT_TAIL;
5610 /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
5611 if ( (STRLEN)minlen < longest_float_length )
5612 minlen= longest_float_length;
5613 if ( (STRLEN)minlen < longest_fixed_length )
5614 minlen= longest_fixed_length;
5618 /* Several toplevels. Best we can is to set minlen. */
5620 struct regnode_charclass_class ch_class;
5623 DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
5625 scan = ri->program + 1;
5626 cl_init(pRExC_state, &ch_class);
5627 data.start_class = &ch_class;
5628 data.last_closep = &last_close;
5631 minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
5632 &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
5636 r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
5637 = r->float_substr = r->float_utf8 = NULL;
5639 if (!(data.start_class->flags & ANYOF_EOS)
5640 && !cl_is_anything(data.start_class))
5642 const U32 n = add_data(pRExC_state, 1, "f");
5643 data.start_class->flags |= ANYOF_IS_SYNTHETIC;
5645 Newx(RExC_rxi->data->data[n], 1,
5646 struct regnode_charclass_class);
5647 StructCopy(data.start_class,
5648 (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5649 struct regnode_charclass_class);
5650 ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5651 r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5652 DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
5653 regprop(r, sv, (regnode*)data.start_class);
5654 PerlIO_printf(Perl_debug_log,
5655 "synthetic stclass \"%s\".\n",
5656 SvPVX_const(sv));});
5660 /* Guard against an embedded (?=) or (?<=) with a longer minlen than
5661 the "real" pattern. */
5663 PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
5664 (IV)minlen, (IV)r->minlen);
5666 r->minlenret = minlen;
5667 if (r->minlen < minlen)
5670 if (RExC_seen & REG_SEEN_GPOS)
5671 r->extflags |= RXf_GPOS_SEEN;
5672 if (RExC_seen & REG_SEEN_LOOKBEHIND)
5673 r->extflags |= RXf_LOOKBEHIND_SEEN;
5674 if (RExC_seen & REG_SEEN_EVAL)
5675 r->extflags |= RXf_EVAL_SEEN;
5676 if (RExC_seen & REG_SEEN_CANY)
5677 r->extflags |= RXf_CANY_SEEN;
5678 if (RExC_seen & REG_SEEN_VERBARG)
5679 r->intflags |= PREGf_VERBARG_SEEN;
5680 if (RExC_seen & REG_SEEN_CUTGROUP)
5681 r->intflags |= PREGf_CUTGROUP_SEEN;
5682 if (RExC_paren_names)
5683 RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
5685 RXp_PAREN_NAMES(r) = NULL;
5687 #ifdef STUPID_PATTERN_CHECKS
5688 if (RX_PRELEN(rx) == 0)
5689 r->extflags |= RXf_NULL;
5690 if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5691 /* XXX: this should happen BEFORE we compile */
5692 r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
5693 else if (RX_PRELEN(rx) == 3 && memEQ("\\s+", RX_PRECOMP(rx), 3))
5694 r->extflags |= RXf_WHITE;
5695 else if (RX_PRELEN(rx) == 1 && RXp_PRECOMP(rx)[0] == '^')
5696 r->extflags |= RXf_START_ONLY;
5698 if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5699 /* XXX: this should happen BEFORE we compile */
5700 r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
5702 regnode *first = ri->program + 1;
5705 if (PL_regkind[fop] == NOTHING && OP(NEXTOPER(first)) == END)
5706 r->extflags |= RXf_NULL;
5707 else if (PL_regkind[fop] == BOL && OP(NEXTOPER(first)) == END)
5708 r->extflags |= RXf_START_ONLY;
5709 else if (fop == PLUS && OP(NEXTOPER(first)) == SPACE
5710 && OP(regnext(first)) == END)
5711 r->extflags |= RXf_WHITE;
5715 if (RExC_paren_names) {
5716 ri->name_list_idx = add_data( pRExC_state, 1, "a" );
5717 ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
5720 ri->name_list_idx = 0;
5722 if (RExC_recurse_count) {
5723 for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
5724 const regnode *scan = RExC_recurse[RExC_recurse_count-1];
5725 ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
5728 Newxz(r->offs, RExC_npar, regexp_paren_pair);
5729 /* assume we don't need to swap parens around before we match */
5732 PerlIO_printf(Perl_debug_log,"Final program:\n");
5735 #ifdef RE_TRACK_PATTERN_OFFSETS
5736 DEBUG_OFFSETS_r(if (ri->u.offsets) {
5737 const U32 len = ri->u.offsets[0];
5739 GET_RE_DEBUG_FLAGS_DECL;
5740 PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
5741 for (i = 1; i <= len; i++) {
5742 if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
5743 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
5744 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
5746 PerlIO_printf(Perl_debug_log, "\n");
5752 #undef RE_ENGINE_PTR
5756 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
5759 PERL_ARGS_ASSERT_REG_NAMED_BUFF;
5761 PERL_UNUSED_ARG(value);
5763 if (flags & RXapif_FETCH) {
5764 return reg_named_buff_fetch(rx, key, flags);
5765 } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
5766 Perl_croak_no_modify(aTHX);
5768 } else if (flags & RXapif_EXISTS) {
5769 return reg_named_buff_exists(rx, key, flags)
5772 } else if (flags & RXapif_REGNAMES) {
5773 return reg_named_buff_all(rx, flags);
5774 } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
5775 return reg_named_buff_scalar(rx, flags);
5777 Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
5783 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
5786 PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
5787 PERL_UNUSED_ARG(lastkey);
5789 if (flags & RXapif_FIRSTKEY)
5790 return reg_named_buff_firstkey(rx, flags);
5791 else if (flags & RXapif_NEXTKEY)
5792 return reg_named_buff_nextkey(rx, flags);
5794 Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", (int)flags);
5800 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
5803 AV *retarray = NULL;
5805 struct regexp *const rx = (struct regexp *)SvANY(r);
5807 PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
5809 if (flags & RXapif_ALL)
5812 if (rx && RXp_PAREN_NAMES(rx)) {
5813 HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
5816 SV* sv_dat=HeVAL(he_str);
5817 I32 *nums=(I32*)SvPVX(sv_dat);
5818 for ( i=0; i<SvIVX(sv_dat); i++ ) {
5819 if ((I32)(rx->nparens) >= nums[i]
5820 && rx->offs[nums[i]].start != -1
5821 && rx->offs[nums[i]].end != -1)
5824 CALLREG_NUMBUF_FETCH(r,nums[i],ret);
5829 ret = newSVsv(&PL_sv_undef);
5832 av_push(retarray, ret);
5835 return newRV_noinc(MUTABLE_SV(retarray));
5842 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
5845 struct regexp *const rx = (struct regexp *)SvANY(r);
5847 PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
5849 if (rx && RXp_PAREN_NAMES(rx)) {
5850 if (flags & RXapif_ALL) {
5851 return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
5853 SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
5867 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
5869 struct regexp *const rx = (struct regexp *)SvANY(r);
5871 PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
5873 if ( rx && RXp_PAREN_NAMES(rx) ) {
5874 (void)hv_iterinit(RXp_PAREN_NAMES(rx));
5876 return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
5883 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
5885 struct regexp *const rx = (struct regexp *)SvANY(r);
5886 GET_RE_DEBUG_FLAGS_DECL;
5888 PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
5890 if (rx && RXp_PAREN_NAMES(rx)) {
5891 HV *hv = RXp_PAREN_NAMES(rx);
5893 while ( (temphe = hv_iternext_flags(hv,0)) ) {
5896 SV* sv_dat = HeVAL(temphe);
5897 I32 *nums = (I32*)SvPVX(sv_dat);
5898 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5899 if ((I32)(rx->lastparen) >= nums[i] &&
5900 rx->offs[nums[i]].start != -1 &&
5901 rx->offs[nums[i]].end != -1)
5907 if (parno || flags & RXapif_ALL) {
5908 return newSVhek(HeKEY_hek(temphe));
5916 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
5921 struct regexp *const rx = (struct regexp *)SvANY(r);
5923 PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
5925 if (rx && RXp_PAREN_NAMES(rx)) {
5926 if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
5927 return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
5928 } else if (flags & RXapif_ONE) {
5929 ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
5930 av = MUTABLE_AV(SvRV(ret));
5931 length = av_len(av);
5933 return newSViv(length + 1);
5935 Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
5939 return &PL_sv_undef;
5943 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
5945 struct regexp *const rx = (struct regexp *)SvANY(r);
5948 PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
5950 if (rx && RXp_PAREN_NAMES(rx)) {
5951 HV *hv= RXp_PAREN_NAMES(rx);
5953 (void)hv_iterinit(hv);
5954 while ( (temphe = hv_iternext_flags(hv,0)) ) {
5957 SV* sv_dat = HeVAL(temphe);
5958 I32 *nums = (I32*)SvPVX(sv_dat);
5959 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5960 if ((I32)(rx->lastparen) >= nums[i] &&
5961 rx->offs[nums[i]].start != -1 &&
5962 rx->offs[nums[i]].end != -1)
5968 if (parno || flags & RXapif_ALL) {
5969 av_push(av, newSVhek(HeKEY_hek(temphe)));
5974 return newRV_noinc(MUTABLE_SV(av));
5978 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
5981 struct regexp *const rx = (struct regexp *)SvANY(r);
5986 PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
5989 sv_setsv(sv,&PL_sv_undef);
5993 if (paren == RX_BUFF_IDX_PREMATCH && rx->offs[0].start != -1) {
5995 i = rx->offs[0].start;
5999 if (paren == RX_BUFF_IDX_POSTMATCH && rx->offs[0].end != -1) {
6001 s = rx->subbeg + rx->offs[0].end;
6002 i = rx->sublen - rx->offs[0].end;
6005 if ( 0 <= paren && paren <= (I32)rx->nparens &&
6006 (s1 = rx->offs[paren].start) != -1 &&
6007 (t1 = rx->offs[paren].end) != -1)
6011 s = rx->subbeg + s1;
6013 sv_setsv(sv,&PL_sv_undef);
6016 assert(rx->sublen >= (s - rx->subbeg) + i );
6018 const int oldtainted = PL_tainted;
6020 sv_setpvn(sv, s, i);
6021 PL_tainted = oldtainted;
6022 if ( (rx->extflags & RXf_CANY_SEEN)
6023 ? (RXp_MATCH_UTF8(rx)
6024 && (!i || is_utf8_string((U8*)s, i)))
6025 : (RXp_MATCH_UTF8(rx)) )
6032 if (RXp_MATCH_TAINTED(rx)) {
6033 if (SvTYPE(sv) >= SVt_PVMG) {
6034 MAGIC* const mg = SvMAGIC(sv);
6037 SvMAGIC_set(sv, mg->mg_moremagic);
6039 if ((mgt = SvMAGIC(sv))) {
6040 mg->mg_moremagic = mgt;
6041 SvMAGIC_set(sv, mg);
6051 sv_setsv(sv,&PL_sv_undef);
6057 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
6058 SV const * const value)
6060 PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
6062 PERL_UNUSED_ARG(rx);
6063 PERL_UNUSED_ARG(paren);
6064 PERL_UNUSED_ARG(value);
6067 Perl_croak_no_modify(aTHX);
6071 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
6074 struct regexp *const rx = (struct regexp *)SvANY(r);
6078 PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
6080 /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
6082 /* $` / ${^PREMATCH} */
6083 case RX_BUFF_IDX_PREMATCH:
6084 if (rx->offs[0].start != -1) {
6085 i = rx->offs[0].start;
6093 /* $' / ${^POSTMATCH} */
6094 case RX_BUFF_IDX_POSTMATCH:
6095 if (rx->offs[0].end != -1) {
6096 i = rx->sublen - rx->offs[0].end;
6098 s1 = rx->offs[0].end;
6104 /* $& / ${^MATCH}, $1, $2, ... */
6106 if (paren <= (I32)rx->nparens &&
6107 (s1 = rx->offs[paren].start) != -1 &&
6108 (t1 = rx->offs[paren].end) != -1)
6113 if (ckWARN(WARN_UNINITIALIZED))
6114 report_uninit((const SV *)sv);
6119 if (i > 0 && RXp_MATCH_UTF8(rx)) {
6120 const char * const s = rx->subbeg + s1;
6125 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
6132 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
6134 PERL_ARGS_ASSERT_REG_QR_PACKAGE;
6135 PERL_UNUSED_ARG(rx);
6139 return newSVpvs("Regexp");
6142 /* Scans the name of a named buffer from the pattern.
6143 * If flags is REG_RSN_RETURN_NULL returns null.
6144 * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
6145 * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
6146 * to the parsed name as looked up in the RExC_paren_names hash.
6147 * If there is an error throws a vFAIL().. type exception.
6150 #define REG_RSN_RETURN_NULL 0
6151 #define REG_RSN_RETURN_NAME 1
6152 #define REG_RSN_RETURN_DATA 2
6155 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
6157 char *name_start = RExC_parse;
6159 PERL_ARGS_ASSERT_REG_SCAN_NAME;
6161 if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
6162 /* skip IDFIRST by using do...while */
6165 RExC_parse += UTF8SKIP(RExC_parse);
6166 } while (isALNUM_utf8((U8*)RExC_parse));
6170 } while (isALNUM(*RExC_parse));
6175 = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
6176 SVs_TEMP | (UTF ? SVf_UTF8 : 0));
6177 if ( flags == REG_RSN_RETURN_NAME)
6179 else if (flags==REG_RSN_RETURN_DATA) {
6182 if ( ! sv_name ) /* should not happen*/
6183 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
6184 if (RExC_paren_names)
6185 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
6187 sv_dat = HeVAL(he_str);
6189 vFAIL("Reference to nonexistent named group");
6193 Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
6194 (unsigned long) flags);
6201 #define DEBUG_PARSE_MSG(funcname) DEBUG_PARSE_r({ \
6202 int rem=(int)(RExC_end - RExC_parse); \
6211 if (RExC_lastparse!=RExC_parse) \
6212 PerlIO_printf(Perl_debug_log," >%.*s%-*s", \
6215 iscut ? "..." : "<" \
6218 PerlIO_printf(Perl_debug_log,"%16s",""); \
6221 num = RExC_size + 1; \
6223 num=REG_NODE_NUM(RExC_emit); \
6224 if (RExC_lastnum!=num) \
6225 PerlIO_printf(Perl_debug_log,"|%4d",num); \
6227 PerlIO_printf(Perl_debug_log,"|%4s",""); \
6228 PerlIO_printf(Perl_debug_log,"|%*s%-4s", \
6229 (int)((depth*2)), "", \
6233 RExC_lastparse=RExC_parse; \
6238 #define DEBUG_PARSE(funcname) DEBUG_PARSE_r({ \
6239 DEBUG_PARSE_MSG((funcname)); \
6240 PerlIO_printf(Perl_debug_log,"%4s","\n"); \
6242 #define DEBUG_PARSE_FMT(funcname,fmt,args) DEBUG_PARSE_r({ \
6243 DEBUG_PARSE_MSG((funcname)); \
6244 PerlIO_printf(Perl_debug_log,fmt "\n",args); \
6247 /* This section of code defines the inversion list object and its methods. The
6248 * interfaces are highly subject to change, so as much as possible is static to
6249 * this file. An inversion list is here implemented as a malloc'd C UV array
6250 * with some added info that is placed as UVs at the beginning in a header
6251 * portion. An inversion list for Unicode is an array of code points, sorted
6252 * by ordinal number. The zeroth element is the first code point in the list.
6253 * The 1th element is the first element beyond that not in the list. In other
6254 * words, the first range is
6255 * invlist[0]..(invlist[1]-1)
6256 * The other ranges follow. Thus every element whose index is divisible by two
6257 * marks the beginning of a range that is in the list, and every element not
6258 * divisible by two marks the beginning of a range not in the list. A single
6259 * element inversion list that contains the single code point N generally
6260 * consists of two elements
6263 * (The exception is when N is the highest representable value on the
6264 * machine, in which case the list containing just it would be a single
6265 * element, itself. By extension, if the last range in the list extends to
6266 * infinity, then the first element of that range will be in the inversion list
6267 * at a position that is divisible by two, and is the final element in the
6269 * Taking the complement (inverting) an inversion list is quite simple, if the
6270 * first element is 0, remove it; otherwise add a 0 element at the beginning.
6271 * This implementation reserves an element at the beginning of each inversion list
6272 * to contain 0 when the list contains 0, and contains 1 otherwise. The actual
6273 * beginning of the list is either that element if 0, or the next one if 1.
6275 * More about inversion lists can be found in "Unicode Demystified"
6276 * Chapter 13 by Richard Gillam, published by Addison-Wesley.
6277 * More will be coming when functionality is added later.
6279 * The inversion list data structure is currently implemented as an SV pointing
6280 * to an array of UVs that the SV thinks are bytes. This allows us to have an
6281 * array of UV whose memory management is automatically handled by the existing
6282 * facilities for SV's.
6284 * Some of the methods should always be private to the implementation, and some
6285 * should eventually be made public */
6287 #define INVLIST_LEN_OFFSET 0 /* Number of elements in the inversion list */
6288 #define INVLIST_ITER_OFFSET 1 /* Current iteration position */
6290 /* This is a combination of a version and data structure type, so that one
6291 * being passed in can be validated to be an inversion list of the correct
6292 * vintage. When the structure of the header is changed, a new random number
6293 * in the range 2**31-1 should be generated and the new() method changed to
6294 * insert that at this location. Then, if an auxiliary program doesn't change
6295 * correspondingly, it will be discovered immediately */
6296 #define INVLIST_VERSION_ID_OFFSET 2
6297 #define INVLIST_VERSION_ID 1064334010
6299 /* For safety, when adding new elements, remember to #undef them at the end of
6300 * the inversion list code section */
6302 #define INVLIST_ZERO_OFFSET 3 /* 0 or 1; must be last element in header */
6303 /* The UV at position ZERO contains either 0 or 1. If 0, the inversion list
6304 * contains the code point U+00000, and begins here. If 1, the inversion list
6305 * doesn't contain U+0000, and it begins at the next UV in the array.
6306 * Inverting an inversion list consists of adding or removing the 0 at the
6307 * beginning of it. By reserving a space for that 0, inversion can be made
6310 #define HEADER_LENGTH (INVLIST_ZERO_OFFSET + 1)
6312 /* Internally things are UVs */
6313 #define TO_INTERNAL_SIZE(x) ((x + HEADER_LENGTH) * sizeof(UV))
6314 #define FROM_INTERNAL_SIZE(x) ((x / sizeof(UV)) - HEADER_LENGTH)
6316 #define INVLIST_INITIAL_LEN 10
6318 PERL_STATIC_INLINE UV*
6319 S__invlist_array_init(pTHX_ SV* const invlist, const bool will_have_0)
6321 /* Returns a pointer to the first element in the inversion list's array.
6322 * This is called upon initialization of an inversion list. Where the
6323 * array begins depends on whether the list has the code point U+0000
6324 * in it or not. The other parameter tells it whether the code that
6325 * follows this call is about to put a 0 in the inversion list or not.
6326 * The first element is either the element with 0, if 0, or the next one,
6329 UV* zero = get_invlist_zero_addr(invlist);
6331 PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
6334 assert(! *get_invlist_len_addr(invlist));
6336 /* 1^1 = 0; 1^0 = 1 */
6337 *zero = 1 ^ will_have_0;
6338 return zero + *zero;
6341 PERL_STATIC_INLINE UV*
6342 S_invlist_array(pTHX_ SV* const invlist)
6344 /* Returns the pointer to the inversion list's array. Every time the
6345 * length changes, this needs to be called in case malloc or realloc moved
6348 PERL_ARGS_ASSERT_INVLIST_ARRAY;
6350 /* Must not be empty. If these fail, you probably didn't check for <len>
6351 * being non-zero before trying to get the array */
6352 assert(*get_invlist_len_addr(invlist));
6353 assert(*get_invlist_zero_addr(invlist) == 0
6354 || *get_invlist_zero_addr(invlist) == 1);
6356 /* The array begins either at the element reserved for zero if the
6357 * list contains 0 (that element will be set to 0), or otherwise the next
6358 * element (in which case the reserved element will be set to 1). */
6359 return (UV *) (get_invlist_zero_addr(invlist)
6360 + *get_invlist_zero_addr(invlist));
6363 PERL_STATIC_INLINE UV*
6364 S_get_invlist_len_addr(pTHX_ SV* invlist)
6366 /* Return the address of the UV that contains the current number
6367 * of used elements in the inversion list */
6369 PERL_ARGS_ASSERT_GET_INVLIST_LEN_ADDR;
6371 return (UV *) (SvPVX(invlist) + (INVLIST_LEN_OFFSET * sizeof (UV)));
6374 PERL_STATIC_INLINE UV
6375 S_invlist_len(pTHX_ SV* const invlist)
6377 /* Returns the current number of elements stored in the inversion list's
6380 PERL_ARGS_ASSERT_INVLIST_LEN;
6382 return *get_invlist_len_addr(invlist);
6385 PERL_STATIC_INLINE void
6386 S_invlist_set_len(pTHX_ SV* const invlist, const UV len)
6388 /* Sets the current number of elements stored in the inversion list */
6390 PERL_ARGS_ASSERT_INVLIST_SET_LEN;
6392 *get_invlist_len_addr(invlist) = len;
6394 assert(len <= SvLEN(invlist));
6396 SvCUR_set(invlist, TO_INTERNAL_SIZE(len));
6397 /* If the list contains U+0000, that element is part of the header,
6398 * and should not be counted as part of the array. It will contain
6399 * 0 in that case, and 1 otherwise. So we could flop 0=>1, 1=>0 and
6401 * SvCUR_set(invlist,
6402 * TO_INTERNAL_SIZE(len
6403 * - (*get_invlist_zero_addr(inv_list) ^ 1)));
6404 * But, this is only valid if len is not 0. The consequences of not doing
6405 * this is that the memory allocation code may think that 1 more UV is
6406 * being used than actually is, and so might do an unnecessary grow. That
6407 * seems worth not bothering to make this the precise amount.
6409 * Note that when inverting, SvCUR shouldn't change */
6412 PERL_STATIC_INLINE UV
6413 S_invlist_max(pTHX_ SV* const invlist)
6415 /* Returns the maximum number of elements storable in the inversion list's
6416 * array, without having to realloc() */
6418 PERL_ARGS_ASSERT_INVLIST_MAX;
6420 return FROM_INTERNAL_SIZE(SvLEN(invlist));
6423 PERL_STATIC_INLINE UV*
6424 S_get_invlist_zero_addr(pTHX_ SV* invlist)
6426 /* Return the address of the UV that is reserved to hold 0 if the inversion
6427 * list contains 0. This has to be the last element of the heading, as the
6428 * list proper starts with either it if 0, or the next element if not.
6429 * (But we force it to contain either 0 or 1) */
6431 PERL_ARGS_ASSERT_GET_INVLIST_ZERO_ADDR;
6433 return (UV *) (SvPVX(invlist) + (INVLIST_ZERO_OFFSET * sizeof (UV)));
6436 #ifndef PERL_IN_XSUB_RE
6438 Perl__new_invlist(pTHX_ IV initial_size)
6441 /* Return a pointer to a newly constructed inversion list, with enough
6442 * space to store 'initial_size' elements. If that number is negative, a
6443 * system default is used instead */
6447 if (initial_size < 0) {
6448 initial_size = INVLIST_INITIAL_LEN;
6451 /* Allocate the initial space */
6452 new_list = newSV(TO_INTERNAL_SIZE(initial_size));
6453 invlist_set_len(new_list, 0);
6455 /* Force iterinit() to be used to get iteration to work */
6456 *get_invlist_iter_addr(new_list) = UV_MAX;
6458 /* This should force a segfault if a method doesn't initialize this
6460 *get_invlist_zero_addr(new_list) = UV_MAX;
6462 *get_invlist_version_id_addr(new_list) = INVLIST_VERSION_ID;
6463 #if HEADER_LENGTH != 4
6464 # 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
6472 S__new_invlist_C_array(pTHX_ UV* list)
6474 /* Return a pointer to a newly constructed inversion list, initialized to
6475 * point to <list>, which has to be in the exact correct inversion list
6476 * form, including internal fields. Thus this is a dangerous routine that
6477 * should not be used in the wrong hands */
6479 SV* invlist = newSV_type(SVt_PV);
6481 PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
6483 SvPV_set(invlist, (char *) list);
6484 SvLEN_set(invlist, 0); /* Means we own the contents, and the system
6485 shouldn't touch it */
6486 SvCUR_set(invlist, TO_INTERNAL_SIZE(invlist_len(invlist)));
6488 if (*get_invlist_version_id_addr(invlist) != INVLIST_VERSION_ID) {
6489 Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
6496 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
6498 /* Grow the maximum size of an inversion list */
6500 PERL_ARGS_ASSERT_INVLIST_EXTEND;
6502 SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max));
6505 PERL_STATIC_INLINE void
6506 S_invlist_trim(pTHX_ SV* const invlist)
6508 PERL_ARGS_ASSERT_INVLIST_TRIM;
6510 /* Change the length of the inversion list to how many entries it currently
6513 SvPV_shrink_to_cur((SV *) invlist);
6516 /* An element is in an inversion list iff its index is even numbered: 0, 2, 4,
6518 #define ELEMENT_RANGE_MATCHES_INVLIST(i) (! ((i) & 1))
6519 #define PREV_RANGE_MATCHES_INVLIST(i) (! ELEMENT_RANGE_MATCHES_INVLIST(i))
6521 #define _invlist_union_complement_2nd(a, b, output) _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
6524 S__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end)
6526 /* Subject to change or removal. Append the range from 'start' to 'end' at
6527 * the end of the inversion list. The range must be above any existing
6531 UV max = invlist_max(invlist);
6532 UV len = invlist_len(invlist);
6534 PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
6536 if (len == 0) { /* Empty lists must be initialized */
6537 array = _invlist_array_init(invlist, start == 0);
6540 /* Here, the existing list is non-empty. The current max entry in the
6541 * list is generally the first value not in the set, except when the
6542 * set extends to the end of permissible values, in which case it is
6543 * the first entry in that final set, and so this call is an attempt to
6544 * append out-of-order */
6546 UV final_element = len - 1;
6547 array = invlist_array(invlist);
6548 if (array[final_element] > start
6549 || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
6551 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",
6552 array[final_element], start,
6553 ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
6556 /* Here, it is a legal append. If the new range begins with the first
6557 * value not in the set, it is extending the set, so the new first
6558 * value not in the set is one greater than the newly extended range.
6560 if (array[final_element] == start) {
6561 if (end != UV_MAX) {
6562 array[final_element] = end + 1;
6565 /* But if the end is the maximum representable on the machine,
6566 * just let the range that this would extend to have no end */
6567 invlist_set_len(invlist, len - 1);
6573 /* Here the new range doesn't extend any existing set. Add it */
6575 len += 2; /* Includes an element each for the start and end of range */
6577 /* If overflows the existing space, extend, which may cause the array to be
6580 invlist_extend(invlist, len);
6581 invlist_set_len(invlist, len); /* Have to set len here to avoid assert
6582 failure in invlist_array() */
6583 array = invlist_array(invlist);
6586 invlist_set_len(invlist, len);
6589 /* The next item on the list starts the range, the one after that is
6590 * one past the new range. */
6591 array[len - 2] = start;
6592 if (end != UV_MAX) {
6593 array[len - 1] = end + 1;
6596 /* But if the end is the maximum representable on the machine, just let
6597 * the range have no end */
6598 invlist_set_len(invlist, len - 1);
6602 #ifndef PERL_IN_XSUB_RE
6605 S_invlist_search(pTHX_ SV* const invlist, const UV cp)
6607 /* Searches the inversion list for the entry that contains the input code
6608 * point <cp>. If <cp> is not in the list, -1 is returned. Otherwise, the
6609 * return value is the index into the list's array of the range that
6613 IV high = invlist_len(invlist);
6614 const UV * const array = invlist_array(invlist);
6616 PERL_ARGS_ASSERT_INVLIST_SEARCH;
6618 /* If list is empty or the code point is before the first element, return
6620 if (high == 0 || cp < array[0]) {
6624 /* Binary search. What we are looking for is <i> such that
6625 * array[i] <= cp < array[i+1]
6626 * The loop below converges on the i+1. */
6627 while (low < high) {
6628 IV mid = (low + high) / 2;
6629 if (array[mid] <= cp) {
6632 /* We could do this extra test to exit the loop early.
6633 if (cp < array[low]) {
6638 else { /* cp < array[mid] */
6647 Perl__invlist_populate_swatch(pTHX_ SV* const invlist, const UV start, const UV end, U8* swatch)
6649 /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
6650 * but is used when the swash has an inversion list. This makes this much
6651 * faster, as it uses a binary search instead of a linear one. This is
6652 * intimately tied to that function, and perhaps should be in utf8.c,
6653 * except it is intimately tied to inversion lists as well. It assumes
6654 * that <swatch> is all 0's on input */
6657 const IV len = invlist_len(invlist);
6661 PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
6663 if (len == 0) { /* Empty inversion list */
6667 array = invlist_array(invlist);
6669 /* Find which element it is */
6670 i = invlist_search(invlist, start);
6672 /* We populate from <start> to <end> */
6673 while (current < end) {
6676 /* The inversion list gives the results for every possible code point
6677 * after the first one in the list. Only those ranges whose index is
6678 * even are ones that the inversion list matches. For the odd ones,
6679 * and if the initial code point is not in the list, we have to skip
6680 * forward to the next element */
6681 if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
6683 if (i >= len) { /* Finished if beyond the end of the array */
6687 if (current >= end) { /* Finished if beyond the end of what we
6692 assert(current >= start);
6694 /* The current range ends one below the next one, except don't go past
6697 upper = (i < len && array[i] < end) ? array[i] : end;
6699 /* Here we are in a range that matches. Populate a bit in the 3-bit U8
6700 * for each code point in it */
6701 for (; current < upper; current++) {
6702 const STRLEN offset = (STRLEN)(current - start);
6703 swatch[offset >> 3] |= 1 << (offset & 7);
6706 /* Quit if at the end of the list */
6709 /* But first, have to deal with the highest possible code point on
6710 * the platform. The previous code assumes that <end> is one
6711 * beyond where we want to populate, but that is impossible at the
6712 * platform's infinity, so have to handle it specially */
6713 if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
6715 const STRLEN offset = (STRLEN)(end - start);
6716 swatch[offset >> 3] |= 1 << (offset & 7);
6721 /* Advance to the next range, which will be for code points not in the
6731 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** output)
6733 /* Take the union of two inversion lists and point <output> to it. *output
6734 * should be defined upon input, and if it points to one of the two lists,
6735 * the reference count to that list will be decremented. The first list,
6736 * <a>, may be NULL, in which case a copy of the second list is returned.
6737 * If <complement_b> is TRUE, the union is taken of the complement
6738 * (inversion) of <b> instead of b itself.
6740 * The basis for this comes from "Unicode Demystified" Chapter 13 by
6741 * Richard Gillam, published by Addison-Wesley, and explained at some
6742 * length there. The preface says to incorporate its examples into your
6743 * code at your own risk.
6745 * The algorithm is like a merge sort.
6747 * XXX A potential performance improvement is to keep track as we go along
6748 * if only one of the inputs contributes to the result, meaning the other
6749 * is a subset of that one. In that case, we can skip the final copy and
6750 * return the larger of the input lists, but then outside code might need
6751 * to keep track of whether to free the input list or not */
6753 UV* array_a; /* a's array */
6755 UV len_a; /* length of a's array */
6758 SV* u; /* the resulting union */
6762 UV i_a = 0; /* current index into a's array */
6766 /* running count, as explained in the algorithm source book; items are
6767 * stopped accumulating and are output when the count changes to/from 0.
6768 * The count is incremented when we start a range that's in the set, and
6769 * decremented when we start a range that's not in the set. So its range
6770 * is 0 to 2. Only when the count is zero is something not in the set.
6774 PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
6777 /* If either one is empty, the union is the other one */
6778 if (a == NULL || ((len_a = invlist_len(a)) == 0)) {
6785 *output = invlist_clone(b);
6787 _invlist_invert(*output);
6789 } /* else *output already = b; */
6792 else if ((len_b = invlist_len(b)) == 0) {
6797 /* The complement of an empty list is a list that has everything in it,
6798 * so the union with <a> includes everything too */
6803 *output = _new_invlist(1);
6804 _append_range_to_invlist(*output, 0, UV_MAX);
6806 else if (*output != a) {
6807 *output = invlist_clone(a);
6809 /* else *output already = a; */
6813 /* Here both lists exist and are non-empty */
6814 array_a = invlist_array(a);
6815 array_b = invlist_array(b);
6817 /* If are to take the union of 'a' with the complement of b, set it
6818 * up so are looking at b's complement. */
6821 /* To complement, we invert: if the first element is 0, remove it. To
6822 * do this, we just pretend the array starts one later, and clear the
6823 * flag as we don't have to do anything else later */
6824 if (array_b[0] == 0) {
6827 complement_b = FALSE;
6831 /* But if the first element is not zero, we unshift a 0 before the
6832 * array. The data structure reserves a space for that 0 (which
6833 * should be a '1' right now), so physical shifting is unneeded,
6834 * but temporarily change that element to 0. Before exiting the
6835 * routine, we must restore the element to '1' */
6842 /* Size the union for the worst case: that the sets are completely
6844 u = _new_invlist(len_a + len_b);
6846 /* Will contain U+0000 if either component does */
6847 array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0)
6848 || (len_b > 0 && array_b[0] == 0));
6850 /* Go through each list item by item, stopping when exhausted one of
6852 while (i_a < len_a && i_b < len_b) {
6853 UV cp; /* The element to potentially add to the union's array */
6854 bool cp_in_set; /* is it in the the input list's set or not */
6856 /* We need to take one or the other of the two inputs for the union.
6857 * Since we are merging two sorted lists, we take the smaller of the
6858 * next items. In case of a tie, we take the one that is in its set
6859 * first. If we took one not in the set first, it would decrement the
6860 * count, possibly to 0 which would cause it to be output as ending the
6861 * range, and the next time through we would take the same number, and
6862 * output it again as beginning the next range. By doing it the
6863 * opposite way, there is no possibility that the count will be
6864 * momentarily decremented to 0, and thus the two adjoining ranges will
6865 * be seamlessly merged. (In a tie and both are in the set or both not
6866 * in the set, it doesn't matter which we take first.) */
6867 if (array_a[i_a] < array_b[i_b]
6868 || (array_a[i_a] == array_b[i_b]
6869 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
6871 cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
6875 cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
6879 /* Here, have chosen which of the two inputs to look at. Only output
6880 * if the running count changes to/from 0, which marks the
6881 * beginning/end of a range in that's in the set */
6884 array_u[i_u++] = cp;
6891 array_u[i_u++] = cp;
6896 /* Here, we are finished going through at least one of the lists, which
6897 * means there is something remaining in at most one. We check if the list
6898 * that hasn't been exhausted is positioned such that we are in the middle
6899 * of a range in its set or not. (i_a and i_b point to the element beyond
6900 * the one we care about.) If in the set, we decrement 'count'; if 0, there
6901 * is potentially more to output.
6902 * There are four cases:
6903 * 1) Both weren't in their sets, count is 0, and remains 0. What's left
6904 * in the union is entirely from the non-exhausted set.
6905 * 2) Both were in their sets, count is 2. Nothing further should
6906 * be output, as everything that remains will be in the exhausted
6907 * list's set, hence in the union; decrementing to 1 but not 0 insures
6909 * 3) the exhausted was in its set, non-exhausted isn't, count is 1.
6910 * Nothing further should be output because the union includes
6911 * everything from the exhausted set. Not decrementing ensures that.
6912 * 4) the exhausted wasn't in its set, non-exhausted is, count is 1;
6913 * decrementing to 0 insures that we look at the remainder of the
6914 * non-exhausted set */
6915 if ((i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
6916 || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
6921 /* The final length is what we've output so far, plus what else is about to
6922 * be output. (If 'count' is non-zero, then the input list we exhausted
6923 * has everything remaining up to the machine's limit in its set, and hence
6924 * in the union, so there will be no further output. */
6927 /* At most one of the subexpressions will be non-zero */
6928 len_u += (len_a - i_a) + (len_b - i_b);
6931 /* Set result to final length, which can change the pointer to array_u, so
6933 if (len_u != invlist_len(u)) {
6934 invlist_set_len(u, len_u);
6936 array_u = invlist_array(u);
6939 /* When 'count' is 0, the list that was exhausted (if one was shorter than
6940 * the other) ended with everything above it not in its set. That means
6941 * that the remaining part of the union is precisely the same as the
6942 * non-exhausted list, so can just copy it unchanged. (If both list were
6943 * exhausted at the same time, then the operations below will be both 0.)
6946 IV copy_count; /* At most one will have a non-zero copy count */
6947 if ((copy_count = len_a - i_a) > 0) {
6948 Copy(array_a + i_a, array_u + i_u, copy_count, UV);
6950 else if ((copy_count = len_b - i_b) > 0) {
6951 Copy(array_b + i_b, array_u + i_u, copy_count, UV);
6955 /* We may be removing a reference to one of the inputs */
6956 if (a == *output || b == *output) {
6957 SvREFCNT_dec(*output);
6960 /* If we've changed b, restore it */
6970 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** i)
6972 /* Take the intersection of two inversion lists and point <i> to it. *i
6973 * should be defined upon input, and if it points to one of the two lists,
6974 * the reference count to that list will be decremented.
6975 * If <complement_b> is TRUE, the result will be the intersection of <a>
6976 * and the complement (or inversion) of <b> instead of <b> directly.
6978 * The basis for this comes from "Unicode Demystified" Chapter 13 by
6979 * Richard Gillam, published by Addison-Wesley, and explained at some
6980 * length there. The preface says to incorporate its examples into your
6981 * code at your own risk. In fact, it had bugs
6983 * The algorithm is like a merge sort, and is essentially the same as the
6987 UV* array_a; /* a's array */
6989 UV len_a; /* length of a's array */
6992 SV* r; /* the resulting intersection */
6996 UV i_a = 0; /* current index into a's array */
7000 /* running count, as explained in the algorithm source book; items are
7001 * stopped accumulating and are output when the count changes to/from 2.
7002 * The count is incremented when we start a range that's in the set, and
7003 * decremented when we start a range that's not in the set. So its range
7004 * is 0 to 2. Only when the count is 2 is something in the intersection.
7008 PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
7011 /* Special case if either one is empty */
7012 len_a = invlist_len(a);
7013 if ((len_a == 0) || ((len_b = invlist_len(b)) == 0)) {
7015 if (len_a != 0 && complement_b) {
7017 /* Here, 'a' is not empty, therefore from the above 'if', 'b' must
7018 * be empty. Here, also we are using 'b's complement, which hence
7019 * must be every possible code point. Thus the intersection is
7022 *i = invlist_clone(a);
7028 /* else *i is already 'a' */
7032 /* Here, 'a' or 'b' is empty and not using the complement of 'b'. The
7033 * intersection must be empty */
7040 *i = _new_invlist(0);
7044 /* Here both lists exist and are non-empty */
7045 array_a = invlist_array(a);
7046 array_b = invlist_array(b);
7048 /* If are to take the intersection of 'a' with the complement of b, set it
7049 * up so are looking at b's complement. */
7052 /* To complement, we invert: if the first element is 0, remove it. To
7053 * do this, we just pretend the array starts one later, and clear the
7054 * flag as we don't have to do anything else later */
7055 if (array_b[0] == 0) {
7058 complement_b = FALSE;
7062 /* But if the first element is not zero, we unshift a 0 before the
7063 * array. The data structure reserves a space for that 0 (which
7064 * should be a '1' right now), so physical shifting is unneeded,
7065 * but temporarily change that element to 0. Before exiting the
7066 * routine, we must restore the element to '1' */
7073 /* Size the intersection for the worst case: that the intersection ends up
7074 * fragmenting everything to be completely disjoint */
7075 r= _new_invlist(len_a + len_b);
7077 /* Will contain U+0000 iff both components do */
7078 array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
7079 && len_b > 0 && array_b[0] == 0);
7081 /* Go through each list item by item, stopping when exhausted one of
7083 while (i_a < len_a && i_b < len_b) {
7084 UV cp; /* The element to potentially add to the intersection's
7086 bool cp_in_set; /* Is it in the input list's set or not */
7088 /* We need to take one or the other of the two inputs for the
7089 * intersection. Since we are merging two sorted lists, we take the
7090 * smaller of the next items. In case of a tie, we take the one that
7091 * is not in its set first (a difference from the union algorithm). If
7092 * we took one in the set first, it would increment the count, possibly
7093 * to 2 which would cause it to be output as starting a range in the
7094 * intersection, and the next time through we would take that same
7095 * number, and output it again as ending the set. By doing it the
7096 * opposite of this, there is no possibility that the count will be
7097 * momentarily incremented to 2. (In a tie and both are in the set or
7098 * both not in the set, it doesn't matter which we take first.) */
7099 if (array_a[i_a] < array_b[i_b]
7100 || (array_a[i_a] == array_b[i_b]
7101 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
7103 cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
7107 cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
7111 /* Here, have chosen which of the two inputs to look at. Only output
7112 * if the running count changes to/from 2, which marks the
7113 * beginning/end of a range that's in the intersection */
7117 array_r[i_r++] = cp;
7122 array_r[i_r++] = cp;
7128 /* Here, we are finished going through at least one of the lists, which
7129 * means there is something remaining in at most one. We check if the list
7130 * that has been exhausted is positioned such that we are in the middle
7131 * of a range in its set or not. (i_a and i_b point to elements 1 beyond
7132 * the ones we care about.) There are four cases:
7133 * 1) Both weren't in their sets, count is 0, and remains 0. There's
7134 * nothing left in the intersection.
7135 * 2) Both were in their sets, count is 2 and perhaps is incremented to
7136 * above 2. What should be output is exactly that which is in the
7137 * non-exhausted set, as everything it has is also in the intersection
7138 * set, and everything it doesn't have can't be in the intersection
7139 * 3) The exhausted was in its set, non-exhausted isn't, count is 1, and
7140 * gets incremented to 2. Like the previous case, the intersection is
7141 * everything that remains in the non-exhausted set.
7142 * 4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
7143 * remains 1. And the intersection has nothing more. */
7144 if ((i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
7145 || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
7150 /* The final length is what we've output so far plus what else is in the
7151 * intersection. At most one of the subexpressions below will be non-zero */
7154 len_r += (len_a - i_a) + (len_b - i_b);
7157 /* Set result to final length, which can change the pointer to array_r, so
7159 if (len_r != invlist_len(r)) {
7160 invlist_set_len(r, len_r);
7162 array_r = invlist_array(r);
7165 /* Finish outputting any remaining */
7166 if (count >= 2) { /* At most one will have a non-zero copy count */
7168 if ((copy_count = len_a - i_a) > 0) {
7169 Copy(array_a + i_a, array_r + i_r, copy_count, UV);
7171 else if ((copy_count = len_b - i_b) > 0) {
7172 Copy(array_b + i_b, array_r + i_r, copy_count, UV);
7176 /* We may be removing a reference to one of the inputs */
7177 if (a == *i || b == *i) {
7181 /* If we've changed b, restore it */
7191 Perl__add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
7193 /* Add the range from 'start' to 'end' inclusive to the inversion list's
7194 * set. A pointer to the inversion list is returned. This may actually be
7195 * a new list, in which case the passed in one has been destroyed. The
7196 * passed in inversion list can be NULL, in which case a new one is created
7197 * with just the one range in it */
7202 if (invlist == NULL) {
7203 invlist = _new_invlist(2);
7207 len = invlist_len(invlist);
7210 /* If comes after the final entry, can just append it to the end */
7212 || start >= invlist_array(invlist)
7213 [invlist_len(invlist) - 1])
7215 _append_range_to_invlist(invlist, start, end);
7219 /* Here, can't just append things, create and return a new inversion list
7220 * which is the union of this range and the existing inversion list */
7221 range_invlist = _new_invlist(2);
7222 _append_range_to_invlist(range_invlist, start, end);
7224 _invlist_union(invlist, range_invlist, &invlist);
7226 /* The temporary can be freed */
7227 SvREFCNT_dec(range_invlist);
7234 PERL_STATIC_INLINE SV*
7235 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
7236 return _add_range_to_invlist(invlist, cp, cp);
7239 #ifndef PERL_IN_XSUB_RE
7241 Perl__invlist_invert(pTHX_ SV* const invlist)
7243 /* Complement the input inversion list. This adds a 0 if the list didn't
7244 * have a zero; removes it otherwise. As described above, the data
7245 * structure is set up so that this is very efficient */
7247 UV* len_pos = get_invlist_len_addr(invlist);
7249 PERL_ARGS_ASSERT__INVLIST_INVERT;
7251 /* The inverse of matching nothing is matching everything */
7252 if (*len_pos == 0) {
7253 _append_range_to_invlist(invlist, 0, UV_MAX);
7257 /* The exclusive or complents 0 to 1; and 1 to 0. If the result is 1, the
7258 * zero element was a 0, so it is being removed, so the length decrements
7259 * by 1; and vice-versa. SvCUR is unaffected */
7260 if (*get_invlist_zero_addr(invlist) ^= 1) {
7269 Perl__invlist_invert_prop(pTHX_ SV* const invlist)
7271 /* Complement the input inversion list (which must be a Unicode property,
7272 * all of which don't match above the Unicode maximum code point.) And
7273 * Perl has chosen to not have the inversion match above that either. This
7274 * adds a 0x110000 if the list didn't end with it, and removes it if it did
7280 PERL_ARGS_ASSERT__INVLIST_INVERT_PROP;
7282 _invlist_invert(invlist);
7284 len = invlist_len(invlist);
7286 if (len != 0) { /* If empty do nothing */
7287 array = invlist_array(invlist);
7288 if (array[len - 1] != PERL_UNICODE_MAX + 1) {
7289 /* Add 0x110000. First, grow if necessary */
7291 if (invlist_max(invlist) < len) {
7292 invlist_extend(invlist, len);
7293 array = invlist_array(invlist);
7295 invlist_set_len(invlist, len);
7296 array[len - 1] = PERL_UNICODE_MAX + 1;
7298 else { /* Remove the 0x110000 */
7299 invlist_set_len(invlist, len - 1);
7307 PERL_STATIC_INLINE SV*
7308 S_invlist_clone(pTHX_ SV* const invlist)
7311 /* Return a new inversion list that is a copy of the input one, which is
7314 /* Need to allocate extra space to accommodate Perl's addition of a
7315 * trailing NUL to SvPV's, since it thinks they are always strings */
7316 SV* new_invlist = _new_invlist(invlist_len(invlist) + 1);
7317 STRLEN length = SvCUR(invlist);
7319 PERL_ARGS_ASSERT_INVLIST_CLONE;
7321 SvCUR_set(new_invlist, length); /* This isn't done automatically */
7322 Copy(SvPVX(invlist), SvPVX(new_invlist), length, char);
7327 PERL_STATIC_INLINE UV*
7328 S_get_invlist_iter_addr(pTHX_ SV* invlist)
7330 /* Return the address of the UV that contains the current iteration
7333 PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
7335 return (UV *) (SvPVX(invlist) + (INVLIST_ITER_OFFSET * sizeof (UV)));
7338 PERL_STATIC_INLINE UV*
7339 S_get_invlist_version_id_addr(pTHX_ SV* invlist)
7341 /* Return the address of the UV that contains the version id. */
7343 PERL_ARGS_ASSERT_GET_INVLIST_VERSION_ID_ADDR;
7345 return (UV *) (SvPVX(invlist) + (INVLIST_VERSION_ID_OFFSET * sizeof (UV)));
7348 PERL_STATIC_INLINE void
7349 S_invlist_iterinit(pTHX_ SV* invlist) /* Initialize iterator for invlist */
7351 PERL_ARGS_ASSERT_INVLIST_ITERINIT;
7353 *get_invlist_iter_addr(invlist) = 0;
7357 S_invlist_iternext(pTHX_ SV* invlist, UV* start, UV* end)
7359 /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
7360 * This call sets in <*start> and <*end>, the next range in <invlist>.
7361 * Returns <TRUE> if successful and the next call will return the next
7362 * range; <FALSE> if was already at the end of the list. If the latter,
7363 * <*start> and <*end> are unchanged, and the next call to this function
7364 * will start over at the beginning of the list */
7366 UV* pos = get_invlist_iter_addr(invlist);
7367 UV len = invlist_len(invlist);
7370 PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
7373 *pos = UV_MAX; /* Force iternit() to be required next time */
7377 array = invlist_array(invlist);
7379 *start = array[(*pos)++];
7385 *end = array[(*pos)++] - 1;
7391 #ifndef PERL_IN_XSUB_RE
7393 Perl__invlist_contents(pTHX_ SV* const invlist)
7395 /* Get the contents of an inversion list into a string SV so that they can
7396 * be printed out. It uses the format traditionally done for debug tracing
7400 SV* output = newSVpvs("\n");
7402 PERL_ARGS_ASSERT__INVLIST_CONTENTS;
7404 invlist_iterinit(invlist);
7405 while (invlist_iternext(invlist, &start, &end)) {
7406 if (end == UV_MAX) {
7407 Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\tINFINITY\n", start);
7409 else if (end != start) {
7410 Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\t%04"UVXf"\n",
7414 Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\n", start);
7424 S_invlist_dump(pTHX_ SV* const invlist, const char * const header)
7426 /* Dumps out the ranges in an inversion list. The string 'header'
7427 * if present is output on a line before the first range */
7431 if (header && strlen(header)) {
7432 PerlIO_printf(Perl_debug_log, "%s\n", header);
7434 invlist_iterinit(invlist);
7435 while (invlist_iternext(invlist, &start, &end)) {
7436 if (end == UV_MAX) {
7437 PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. INFINITY\n", start);
7440 PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. 0x%04"UVXf"\n", start, end);
7446 #undef HEADER_LENGTH
7447 #undef INVLIST_INITIAL_LENGTH
7448 #undef TO_INTERNAL_SIZE
7449 #undef FROM_INTERNAL_SIZE
7450 #undef INVLIST_LEN_OFFSET
7451 #undef INVLIST_ZERO_OFFSET
7452 #undef INVLIST_ITER_OFFSET
7453 #undef INVLIST_VERSION_ID
7455 /* End of inversion list object */
7458 - reg - regular expression, i.e. main body or parenthesized thing
7460 * Caller must absorb opening parenthesis.
7462 * Combining parenthesis handling with the base level of regular expression
7463 * is a trifle forced, but the need to tie the tails of the branches to what
7464 * follows makes it hard to avoid.
7466 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
7468 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
7470 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
7474 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
7475 /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
7478 register regnode *ret; /* Will be the head of the group. */
7479 register regnode *br;
7480 register regnode *lastbr;
7481 register regnode *ender = NULL;
7482 register I32 parno = 0;
7484 U32 oregflags = RExC_flags;
7485 bool have_branch = 0;
7487 I32 freeze_paren = 0;
7488 I32 after_freeze = 0;
7490 /* for (?g), (?gc), and (?o) warnings; warning
7491 about (?c) will warn about (?g) -- japhy */
7493 #define WASTED_O 0x01
7494 #define WASTED_G 0x02
7495 #define WASTED_C 0x04
7496 #define WASTED_GC (0x02|0x04)
7497 I32 wastedflags = 0x00;
7499 char * parse_start = RExC_parse; /* MJD */
7500 char * const oregcomp_parse = RExC_parse;
7502 GET_RE_DEBUG_FLAGS_DECL;
7504 PERL_ARGS_ASSERT_REG;
7505 DEBUG_PARSE("reg ");
7507 *flagp = 0; /* Tentatively. */
7510 /* Make an OPEN node, if parenthesized. */
7512 if ( *RExC_parse == '*') { /* (*VERB:ARG) */
7513 char *start_verb = RExC_parse;
7514 STRLEN verb_len = 0;
7515 char *start_arg = NULL;
7516 unsigned char op = 0;
7518 int internal_argval = 0; /* internal_argval is only useful if !argok */
7519 while ( *RExC_parse && *RExC_parse != ')' ) {
7520 if ( *RExC_parse == ':' ) {
7521 start_arg = RExC_parse + 1;
7527 verb_len = RExC_parse - start_verb;
7530 while ( *RExC_parse && *RExC_parse != ')' )
7532 if ( *RExC_parse != ')' )
7533 vFAIL("Unterminated verb pattern argument");
7534 if ( RExC_parse == start_arg )
7537 if ( *RExC_parse != ')' )
7538 vFAIL("Unterminated verb pattern");
7541 switch ( *start_verb ) {
7542 case 'A': /* (*ACCEPT) */
7543 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
7545 internal_argval = RExC_nestroot;
7548 case 'C': /* (*COMMIT) */
7549 if ( memEQs(start_verb,verb_len,"COMMIT") )
7552 case 'F': /* (*FAIL) */
7553 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
7558 case ':': /* (*:NAME) */
7559 case 'M': /* (*MARK:NAME) */
7560 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
7565 case 'P': /* (*PRUNE) */
7566 if ( memEQs(start_verb,verb_len,"PRUNE") )
7569 case 'S': /* (*SKIP) */
7570 if ( memEQs(start_verb,verb_len,"SKIP") )
7573 case 'T': /* (*THEN) */
7574 /* [19:06] <TimToady> :: is then */
7575 if ( memEQs(start_verb,verb_len,"THEN") ) {
7577 RExC_seen |= REG_SEEN_CUTGROUP;
7583 vFAIL3("Unknown verb pattern '%.*s'",
7584 verb_len, start_verb);
7587 if ( start_arg && internal_argval ) {
7588 vFAIL3("Verb pattern '%.*s' may not have an argument",
7589 verb_len, start_verb);
7590 } else if ( argok < 0 && !start_arg ) {
7591 vFAIL3("Verb pattern '%.*s' has a mandatory argument",
7592 verb_len, start_verb);
7594 ret = reganode(pRExC_state, op, internal_argval);
7595 if ( ! internal_argval && ! SIZE_ONLY ) {
7597 SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
7598 ARG(ret) = add_data( pRExC_state, 1, "S" );
7599 RExC_rxi->data->data[ARG(ret)]=(void*)sv;
7606 if (!internal_argval)
7607 RExC_seen |= REG_SEEN_VERBARG;
7608 } else if ( start_arg ) {
7609 vFAIL3("Verb pattern '%.*s' may not have an argument",
7610 verb_len, start_verb);
7612 ret = reg_node(pRExC_state, op);
7614 nextchar(pRExC_state);
7617 if (*RExC_parse == '?') { /* (?...) */
7618 bool is_logical = 0;
7619 const char * const seqstart = RExC_parse;
7620 bool has_use_defaults = FALSE;
7623 paren = *RExC_parse++;
7624 ret = NULL; /* For look-ahead/behind. */
7627 case 'P': /* (?P...) variants for those used to PCRE/Python */
7628 paren = *RExC_parse++;
7629 if ( paren == '<') /* (?P<...>) named capture */
7631 else if (paren == '>') { /* (?P>name) named recursion */
7632 goto named_recursion;
7634 else if (paren == '=') { /* (?P=...) named backref */
7635 /* this pretty much dupes the code for \k<NAME> in regatom(), if
7636 you change this make sure you change that */
7637 char* name_start = RExC_parse;
7639 SV *sv_dat = reg_scan_name(pRExC_state,
7640 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
7641 if (RExC_parse == name_start || *RExC_parse != ')')
7642 vFAIL2("Sequence %.3s... not terminated",parse_start);
7645 num = add_data( pRExC_state, 1, "S" );
7646 RExC_rxi->data->data[num]=(void*)sv_dat;
7647 SvREFCNT_inc_simple_void(sv_dat);
7650 ret = reganode(pRExC_state,
7653 : (MORE_ASCII_RESTRICTED)
7655 : (AT_LEAST_UNI_SEMANTICS)
7663 Set_Node_Offset(ret, parse_start+1);
7664 Set_Node_Cur_Length(ret); /* MJD */
7666 nextchar(pRExC_state);
7670 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7672 case '<': /* (?<...) */
7673 if (*RExC_parse == '!')
7675 else if (*RExC_parse != '=')
7681 case '\'': /* (?'...') */
7682 name_start= RExC_parse;
7683 svname = reg_scan_name(pRExC_state,
7684 SIZE_ONLY ? /* reverse test from the others */
7685 REG_RSN_RETURN_NAME :
7686 REG_RSN_RETURN_NULL);
7687 if (RExC_parse == name_start) {
7689 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7692 if (*RExC_parse != paren)
7693 vFAIL2("Sequence (?%c... not terminated",
7694 paren=='>' ? '<' : paren);
7698 if (!svname) /* shouldn't happen */
7700 "panic: reg_scan_name returned NULL");
7701 if (!RExC_paren_names) {
7702 RExC_paren_names= newHV();
7703 sv_2mortal(MUTABLE_SV(RExC_paren_names));
7705 RExC_paren_name_list= newAV();
7706 sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
7709 he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
7711 sv_dat = HeVAL(he_str);
7713 /* croak baby croak */
7715 "panic: paren_name hash element allocation failed");
7716 } else if ( SvPOK(sv_dat) ) {
7717 /* (?|...) can mean we have dupes so scan to check
7718 its already been stored. Maybe a flag indicating
7719 we are inside such a construct would be useful,
7720 but the arrays are likely to be quite small, so
7721 for now we punt -- dmq */
7722 IV count = SvIV(sv_dat);
7723 I32 *pv = (I32*)SvPVX(sv_dat);
7725 for ( i = 0 ; i < count ; i++ ) {
7726 if ( pv[i] == RExC_npar ) {
7732 pv = (I32*)SvGROW(sv_dat, SvCUR(sv_dat) + sizeof(I32)+1);
7733 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
7734 pv[count] = RExC_npar;
7735 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
7738 (void)SvUPGRADE(sv_dat,SVt_PVNV);
7739 sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
7741 SvIV_set(sv_dat, 1);
7744 /* Yes this does cause a memory leak in debugging Perls */
7745 if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
7746 SvREFCNT_dec(svname);
7749 /*sv_dump(sv_dat);*/
7751 nextchar(pRExC_state);
7753 goto capturing_parens;
7755 RExC_seen |= REG_SEEN_LOOKBEHIND;
7756 RExC_in_lookbehind++;
7758 case '=': /* (?=...) */
7759 RExC_seen_zerolen++;
7761 case '!': /* (?!...) */
7762 RExC_seen_zerolen++;
7763 if (*RExC_parse == ')') {
7764 ret=reg_node(pRExC_state, OPFAIL);
7765 nextchar(pRExC_state);
7769 case '|': /* (?|...) */
7770 /* branch reset, behave like a (?:...) except that
7771 buffers in alternations share the same numbers */
7773 after_freeze = freeze_paren = RExC_npar;
7775 case ':': /* (?:...) */
7776 case '>': /* (?>...) */
7778 case '$': /* (?$...) */
7779 case '@': /* (?@...) */
7780 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
7782 case '#': /* (?#...) */
7783 while (*RExC_parse && *RExC_parse != ')')
7785 if (*RExC_parse != ')')
7786 FAIL("Sequence (?#... not terminated");
7787 nextchar(pRExC_state);
7790 case '0' : /* (?0) */
7791 case 'R' : /* (?R) */
7792 if (*RExC_parse != ')')
7793 FAIL("Sequence (?R) not terminated");
7794 ret = reg_node(pRExC_state, GOSTART);
7795 *flagp |= POSTPONED;
7796 nextchar(pRExC_state);
7799 { /* named and numeric backreferences */
7801 case '&': /* (?&NAME) */
7802 parse_start = RExC_parse - 1;
7805 SV *sv_dat = reg_scan_name(pRExC_state,
7806 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
7807 num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
7809 goto gen_recurse_regop;
7812 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
7814 vFAIL("Illegal pattern");
7816 goto parse_recursion;
7818 case '-': /* (?-1) */
7819 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
7820 RExC_parse--; /* rewind to let it be handled later */
7824 case '1': case '2': case '3': case '4': /* (?1) */
7825 case '5': case '6': case '7': case '8': case '9':
7828 num = atoi(RExC_parse);
7829 parse_start = RExC_parse - 1; /* MJD */
7830 if (*RExC_parse == '-')
7832 while (isDIGIT(*RExC_parse))
7834 if (*RExC_parse!=')')
7835 vFAIL("Expecting close bracket");
7838 if ( paren == '-' ) {
7840 Diagram of capture buffer numbering.
7841 Top line is the normal capture buffer numbers
7842 Bottom line is the negative indexing as from
7846 /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
7850 num = RExC_npar + num;
7853 vFAIL("Reference to nonexistent group");
7855 } else if ( paren == '+' ) {
7856 num = RExC_npar + num - 1;
7859 ret = reganode(pRExC_state, GOSUB, num);
7861 if (num > (I32)RExC_rx->nparens) {
7863 vFAIL("Reference to nonexistent group");
7865 ARG2L_SET( ret, RExC_recurse_count++);
7867 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
7868 "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
7872 RExC_seen |= REG_SEEN_RECURSE;
7873 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
7874 Set_Node_Offset(ret, parse_start); /* MJD */
7876 *flagp |= POSTPONED;
7877 nextchar(pRExC_state);
7879 } /* named and numeric backreferences */
7882 case '?': /* (??...) */
7884 if (*RExC_parse != '{') {
7886 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7889 *flagp |= POSTPONED;
7890 paren = *RExC_parse++;
7892 case '{': /* (?{...}) */
7897 char *s = RExC_parse;
7899 RExC_seen_zerolen++;
7900 RExC_seen |= REG_SEEN_EVAL;
7901 while (count && (c = *RExC_parse)) {
7912 if (*RExC_parse != ')') {
7914 vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
7918 OP_4tree *sop, *rop;
7919 SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
7922 Perl_save_re_context(aTHX);
7923 rop = Perl_sv_compile_2op_is_broken(aTHX_ sv, &sop, "re", &pad);
7924 sop->op_private |= OPpREFCOUNTED;
7925 /* re_dup will OpREFCNT_inc */
7926 OpREFCNT_set(sop, 1);
7929 n = add_data(pRExC_state, 3, "nop");
7930 RExC_rxi->data->data[n] = (void*)rop;
7931 RExC_rxi->data->data[n+1] = (void*)sop;
7932 RExC_rxi->data->data[n+2] = (void*)pad;
7935 else { /* First pass */
7936 if (PL_reginterp_cnt < ++RExC_seen_evals
7938 /* No compiled RE interpolated, has runtime
7939 components ===> unsafe. */
7940 FAIL("Eval-group not allowed at runtime, use re 'eval'");
7941 if (PL_tainting && PL_tainted)
7942 FAIL("Eval-group in insecure regular expression");
7943 #if PERL_VERSION > 8
7944 if (IN_PERL_COMPILETIME)
7949 nextchar(pRExC_state);
7951 ret = reg_node(pRExC_state, LOGICAL);
7954 REGTAIL(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
7955 /* deal with the length of this later - MJD */
7958 ret = reganode(pRExC_state, EVAL, n);
7959 Set_Node_Length(ret, RExC_parse - parse_start + 1);
7960 Set_Node_Offset(ret, parse_start);
7963 case '(': /* (?(?{...})...) and (?(?=...)...) */
7966 if (RExC_parse[0] == '?') { /* (?(?...)) */
7967 if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
7968 || RExC_parse[1] == '<'
7969 || RExC_parse[1] == '{') { /* Lookahead or eval. */
7972 ret = reg_node(pRExC_state, LOGICAL);
7975 REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
7979 else if ( RExC_parse[0] == '<' /* (?(<NAME>)...) */
7980 || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
7982 char ch = RExC_parse[0] == '<' ? '>' : '\'';
7983 char *name_start= RExC_parse++;
7985 SV *sv_dat=reg_scan_name(pRExC_state,
7986 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
7987 if (RExC_parse == name_start || *RExC_parse != ch)
7988 vFAIL2("Sequence (?(%c... not terminated",
7989 (ch == '>' ? '<' : ch));
7992 num = add_data( pRExC_state, 1, "S" );
7993 RExC_rxi->data->data[num]=(void*)sv_dat;
7994 SvREFCNT_inc_simple_void(sv_dat);
7996 ret = reganode(pRExC_state,NGROUPP,num);
7997 goto insert_if_check_paren;
7999 else if (RExC_parse[0] == 'D' &&
8000 RExC_parse[1] == 'E' &&
8001 RExC_parse[2] == 'F' &&
8002 RExC_parse[3] == 'I' &&
8003 RExC_parse[4] == 'N' &&
8004 RExC_parse[5] == 'E')
8006 ret = reganode(pRExC_state,DEFINEP,0);
8009 goto insert_if_check_paren;
8011 else if (RExC_parse[0] == 'R') {
8014 if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
8015 parno = atoi(RExC_parse++);
8016 while (isDIGIT(*RExC_parse))
8018 } else if (RExC_parse[0] == '&') {
8021 sv_dat = reg_scan_name(pRExC_state,
8022 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8023 parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
8025 ret = reganode(pRExC_state,INSUBP,parno);
8026 goto insert_if_check_paren;
8028 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
8031 parno = atoi(RExC_parse++);
8033 while (isDIGIT(*RExC_parse))
8035 ret = reganode(pRExC_state, GROUPP, parno);
8037 insert_if_check_paren:
8038 if ((c = *nextchar(pRExC_state)) != ')')
8039 vFAIL("Switch condition not recognized");
8041 REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
8042 br = regbranch(pRExC_state, &flags, 1,depth+1);
8044 br = reganode(pRExC_state, LONGJMP, 0);
8046 REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
8047 c = *nextchar(pRExC_state);
8052 vFAIL("(?(DEFINE)....) does not allow branches");
8053 lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
8054 regbranch(pRExC_state, &flags, 1,depth+1);
8055 REGTAIL(pRExC_state, ret, lastbr);
8058 c = *nextchar(pRExC_state);
8063 vFAIL("Switch (?(condition)... contains too many branches");
8064 ender = reg_node(pRExC_state, TAIL);
8065 REGTAIL(pRExC_state, br, ender);
8067 REGTAIL(pRExC_state, lastbr, ender);
8068 REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
8071 REGTAIL(pRExC_state, ret, ender);
8072 RExC_size++; /* XXX WHY do we need this?!!
8073 For large programs it seems to be required
8074 but I can't figure out why. -- dmq*/
8078 vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
8082 RExC_parse--; /* for vFAIL to print correctly */
8083 vFAIL("Sequence (? incomplete");
8085 case DEFAULT_PAT_MOD: /* Use default flags with the exceptions
8087 has_use_defaults = TRUE;
8088 STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
8089 set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
8090 ? REGEX_UNICODE_CHARSET
8091 : REGEX_DEPENDS_CHARSET);
8095 parse_flags: /* (?i) */
8097 U32 posflags = 0, negflags = 0;
8098 U32 *flagsp = &posflags;
8099 char has_charset_modifier = '\0';
8100 regex_charset cs = get_regex_charset(RExC_flags);
8101 if (cs == REGEX_DEPENDS_CHARSET
8102 && (RExC_utf8 || RExC_uni_semantics))
8104 cs = REGEX_UNICODE_CHARSET;
8107 while (*RExC_parse) {
8108 /* && strchr("iogcmsx", *RExC_parse) */
8109 /* (?g), (?gc) and (?o) are useless here
8110 and must be globally applied -- japhy */
8111 switch (*RExC_parse) {
8112 CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
8113 case LOCALE_PAT_MOD:
8114 if (has_charset_modifier) {
8115 goto excess_modifier;
8117 else if (flagsp == &negflags) {
8120 cs = REGEX_LOCALE_CHARSET;
8121 has_charset_modifier = LOCALE_PAT_MOD;
8122 RExC_contains_locale = 1;
8124 case UNICODE_PAT_MOD:
8125 if (has_charset_modifier) {
8126 goto excess_modifier;
8128 else if (flagsp == &negflags) {
8131 cs = REGEX_UNICODE_CHARSET;
8132 has_charset_modifier = UNICODE_PAT_MOD;
8134 case ASCII_RESTRICT_PAT_MOD:
8135 if (flagsp == &negflags) {
8138 if (has_charset_modifier) {
8139 if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
8140 goto excess_modifier;
8142 /* Doubled modifier implies more restricted */
8143 cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
8146 cs = REGEX_ASCII_RESTRICTED_CHARSET;
8148 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
8150 case DEPENDS_PAT_MOD:
8151 if (has_use_defaults) {
8152 goto fail_modifiers;
8154 else if (flagsp == &negflags) {
8157 else if (has_charset_modifier) {
8158 goto excess_modifier;
8161 /* The dual charset means unicode semantics if the
8162 * pattern (or target, not known until runtime) are
8163 * utf8, or something in the pattern indicates unicode
8165 cs = (RExC_utf8 || RExC_uni_semantics)
8166 ? REGEX_UNICODE_CHARSET
8167 : REGEX_DEPENDS_CHARSET;
8168 has_charset_modifier = DEPENDS_PAT_MOD;
8172 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
8173 vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
8175 else if (has_charset_modifier == *(RExC_parse - 1)) {
8176 vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1));
8179 vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
8184 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1));
8186 case ONCE_PAT_MOD: /* 'o' */
8187 case GLOBAL_PAT_MOD: /* 'g' */
8188 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8189 const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
8190 if (! (wastedflags & wflagbit) ) {
8191 wastedflags |= wflagbit;
8194 "Useless (%s%c) - %suse /%c modifier",
8195 flagsp == &negflags ? "?-" : "?",
8197 flagsp == &negflags ? "don't " : "",
8204 case CONTINUE_PAT_MOD: /* 'c' */
8205 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8206 if (! (wastedflags & WASTED_C) ) {
8207 wastedflags |= WASTED_GC;
8210 "Useless (%sc) - %suse /gc modifier",
8211 flagsp == &negflags ? "?-" : "?",
8212 flagsp == &negflags ? "don't " : ""
8217 case KEEPCOPY_PAT_MOD: /* 'p' */
8218 if (flagsp == &negflags) {
8220 ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
8222 *flagsp |= RXf_PMf_KEEPCOPY;
8226 /* A flag is a default iff it is following a minus, so
8227 * if there is a minus, it means will be trying to
8228 * re-specify a default which is an error */
8229 if (has_use_defaults || flagsp == &negflags) {
8232 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8236 wastedflags = 0; /* reset so (?g-c) warns twice */
8242 RExC_flags |= posflags;
8243 RExC_flags &= ~negflags;
8244 set_regex_charset(&RExC_flags, cs);
8246 oregflags |= posflags;
8247 oregflags &= ~negflags;
8248 set_regex_charset(&oregflags, cs);
8250 nextchar(pRExC_state);
8261 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8266 }} /* one for the default block, one for the switch */
8273 ret = reganode(pRExC_state, OPEN, parno);
8276 RExC_nestroot = parno;
8277 if (RExC_seen & REG_SEEN_RECURSE
8278 && !RExC_open_parens[parno-1])
8280 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
8281 "Setting open paren #%"IVdf" to %d\n",
8282 (IV)parno, REG_NODE_NUM(ret)));
8283 RExC_open_parens[parno-1]= ret;
8286 Set_Node_Length(ret, 1); /* MJD */
8287 Set_Node_Offset(ret, RExC_parse); /* MJD */
8295 /* Pick up the branches, linking them together. */
8296 parse_start = RExC_parse; /* MJD */
8297 br = regbranch(pRExC_state, &flags, 1,depth+1);
8299 /* branch_len = (paren != 0); */
8303 if (*RExC_parse == '|') {
8304 if (!SIZE_ONLY && RExC_extralen) {
8305 reginsert(pRExC_state, BRANCHJ, br, depth+1);
8308 reginsert(pRExC_state, BRANCH, br, depth+1);
8309 Set_Node_Length(br, paren != 0);
8310 Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
8314 RExC_extralen += 1; /* For BRANCHJ-BRANCH. */
8316 else if (paren == ':') {
8317 *flagp |= flags&SIMPLE;
8319 if (is_open) { /* Starts with OPEN. */
8320 REGTAIL(pRExC_state, ret, br); /* OPEN -> first. */
8322 else if (paren != '?') /* Not Conditional */
8324 *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
8326 while (*RExC_parse == '|') {
8327 if (!SIZE_ONLY && RExC_extralen) {
8328 ender = reganode(pRExC_state, LONGJMP,0);
8329 REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
8332 RExC_extralen += 2; /* Account for LONGJMP. */
8333 nextchar(pRExC_state);
8335 if (RExC_npar > after_freeze)
8336 after_freeze = RExC_npar;
8337 RExC_npar = freeze_paren;
8339 br = regbranch(pRExC_state, &flags, 0, depth+1);
8343 REGTAIL(pRExC_state, lastbr, br); /* BRANCH -> BRANCH. */
8345 *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
8348 if (have_branch || paren != ':') {
8349 /* Make a closing node, and hook it on the end. */
8352 ender = reg_node(pRExC_state, TAIL);
8355 ender = reganode(pRExC_state, CLOSE, parno);
8356 if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
8357 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
8358 "Setting close paren #%"IVdf" to %d\n",
8359 (IV)parno, REG_NODE_NUM(ender)));
8360 RExC_close_parens[parno-1]= ender;
8361 if (RExC_nestroot == parno)
8364 Set_Node_Offset(ender,RExC_parse+1); /* MJD */
8365 Set_Node_Length(ender,1); /* MJD */
8371 *flagp &= ~HASWIDTH;
8374 ender = reg_node(pRExC_state, SUCCEED);
8377 ender = reg_node(pRExC_state, END);
8379 assert(!RExC_opend); /* there can only be one! */
8384 REGTAIL(pRExC_state, lastbr, ender);
8386 if (have_branch && !SIZE_ONLY) {
8388 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
8390 /* Hook the tails of the branches to the closing node. */
8391 for (br = ret; br; br = regnext(br)) {
8392 const U8 op = PL_regkind[OP(br)];
8394 REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
8396 else if (op == BRANCHJ) {
8397 REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
8405 static const char parens[] = "=!<,>";
8407 if (paren && (p = strchr(parens, paren))) {
8408 U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
8409 int flag = (p - parens) > 1;
8412 node = SUSPEND, flag = 0;
8413 reginsert(pRExC_state, node,ret, depth+1);
8414 Set_Node_Cur_Length(ret);
8415 Set_Node_Offset(ret, parse_start + 1);
8417 REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
8421 /* Check for proper termination. */
8423 RExC_flags = oregflags;
8424 if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
8425 RExC_parse = oregcomp_parse;
8426 vFAIL("Unmatched (");
8429 else if (!paren && RExC_parse < RExC_end) {
8430 if (*RExC_parse == ')') {
8432 vFAIL("Unmatched )");
8435 FAIL("Junk on end of regexp"); /* "Can't happen". */
8439 if (RExC_in_lookbehind) {
8440 RExC_in_lookbehind--;
8442 if (after_freeze > RExC_npar)
8443 RExC_npar = after_freeze;
8448 - regbranch - one alternative of an | operator
8450 * Implements the concatenation operator.
8453 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
8456 register regnode *ret;
8457 register regnode *chain = NULL;
8458 register regnode *latest;
8459 I32 flags = 0, c = 0;
8460 GET_RE_DEBUG_FLAGS_DECL;
8462 PERL_ARGS_ASSERT_REGBRANCH;
8464 DEBUG_PARSE("brnc");
8469 if (!SIZE_ONLY && RExC_extralen)
8470 ret = reganode(pRExC_state, BRANCHJ,0);
8472 ret = reg_node(pRExC_state, BRANCH);
8473 Set_Node_Length(ret, 1);
8477 if (!first && SIZE_ONLY)
8478 RExC_extralen += 1; /* BRANCHJ */
8480 *flagp = WORST; /* Tentatively. */
8483 nextchar(pRExC_state);
8484 while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
8486 latest = regpiece(pRExC_state, &flags,depth+1);
8487 if (latest == NULL) {
8488 if (flags & TRYAGAIN)
8492 else if (ret == NULL)
8494 *flagp |= flags&(HASWIDTH|POSTPONED);
8495 if (chain == NULL) /* First piece. */
8496 *flagp |= flags&SPSTART;
8499 REGTAIL(pRExC_state, chain, latest);
8504 if (chain == NULL) { /* Loop ran zero times. */
8505 chain = reg_node(pRExC_state, NOTHING);
8510 *flagp |= flags&SIMPLE;
8517 - regpiece - something followed by possible [*+?]
8519 * Note that the branching code sequences used for ? and the general cases
8520 * of * and + are somewhat optimized: they use the same NOTHING node as
8521 * both the endmarker for their branch list and the body of the last branch.
8522 * It might seem that this node could be dispensed with entirely, but the
8523 * endmarker role is not redundant.
8526 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
8529 register regnode *ret;
8531 register char *next;
8533 const char * const origparse = RExC_parse;
8535 I32 max = REG_INFTY;
8536 #ifdef RE_TRACK_PATTERN_OFFSETS
8539 const char *maxpos = NULL;
8540 GET_RE_DEBUG_FLAGS_DECL;
8542 PERL_ARGS_ASSERT_REGPIECE;
8544 DEBUG_PARSE("piec");
8546 ret = regatom(pRExC_state, &flags,depth+1);
8548 if (flags & TRYAGAIN)
8555 if (op == '{' && regcurly(RExC_parse)) {
8557 #ifdef RE_TRACK_PATTERN_OFFSETS
8558 parse_start = RExC_parse; /* MJD */
8560 next = RExC_parse + 1;
8561 while (isDIGIT(*next) || *next == ',') {
8570 if (*next == '}') { /* got one */
8574 min = atoi(RExC_parse);
8578 maxpos = RExC_parse;
8580 if (!max && *maxpos != '0')
8581 max = REG_INFTY; /* meaning "infinity" */
8582 else if (max >= REG_INFTY)
8583 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
8585 nextchar(pRExC_state);
8588 if ((flags&SIMPLE)) {
8589 RExC_naughty += 2 + RExC_naughty / 2;
8590 reginsert(pRExC_state, CURLY, ret, depth+1);
8591 Set_Node_Offset(ret, parse_start+1); /* MJD */
8592 Set_Node_Cur_Length(ret);
8595 regnode * const w = reg_node(pRExC_state, WHILEM);
8598 REGTAIL(pRExC_state, ret, w);
8599 if (!SIZE_ONLY && RExC_extralen) {
8600 reginsert(pRExC_state, LONGJMP,ret, depth+1);
8601 reginsert(pRExC_state, NOTHING,ret, depth+1);
8602 NEXT_OFF(ret) = 3; /* Go over LONGJMP. */
8604 reginsert(pRExC_state, CURLYX,ret, depth+1);
8606 Set_Node_Offset(ret, parse_start+1);
8607 Set_Node_Length(ret,
8608 op == '{' ? (RExC_parse - parse_start) : 1);
8610 if (!SIZE_ONLY && RExC_extralen)
8611 NEXT_OFF(ret) = 3; /* Go over NOTHING to LONGJMP. */
8612 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
8614 RExC_whilem_seen++, RExC_extralen += 3;
8615 RExC_naughty += 4 + RExC_naughty; /* compound interest */
8624 vFAIL("Can't do {n,m} with n > m");
8626 ARG1_SET(ret, (U16)min);
8627 ARG2_SET(ret, (U16)max);
8639 #if 0 /* Now runtime fix should be reliable. */
8641 /* if this is reinstated, don't forget to put this back into perldiag:
8643 =item Regexp *+ operand could be empty at {#} in regex m/%s/
8645 (F) The part of the regexp subject to either the * or + quantifier
8646 could match an empty string. The {#} shows in the regular
8647 expression about where the problem was discovered.
8651 if (!(flags&HASWIDTH) && op != '?')
8652 vFAIL("Regexp *+ operand could be empty");
8655 #ifdef RE_TRACK_PATTERN_OFFSETS
8656 parse_start = RExC_parse;
8658 nextchar(pRExC_state);
8660 *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
8662 if (op == '*' && (flags&SIMPLE)) {
8663 reginsert(pRExC_state, STAR, ret, depth+1);
8667 else if (op == '*') {
8671 else if (op == '+' && (flags&SIMPLE)) {
8672 reginsert(pRExC_state, PLUS, ret, depth+1);
8676 else if (op == '+') {
8680 else if (op == '?') {
8685 if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
8686 ckWARN3reg(RExC_parse,
8687 "%.*s matches null string many times",
8688 (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
8692 if (RExC_parse < RExC_end && *RExC_parse == '?') {
8693 nextchar(pRExC_state);
8694 reginsert(pRExC_state, MINMOD, ret, depth+1);
8695 REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
8697 #ifndef REG_ALLOW_MINMOD_SUSPEND
8700 if (RExC_parse < RExC_end && *RExC_parse == '+') {
8702 nextchar(pRExC_state);
8703 ender = reg_node(pRExC_state, SUCCEED);
8704 REGTAIL(pRExC_state, ret, ender);
8705 reginsert(pRExC_state, SUSPEND, ret, depth+1);
8707 ender = reg_node(pRExC_state, TAIL);
8708 REGTAIL(pRExC_state, ret, ender);
8712 if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
8714 vFAIL("Nested quantifiers");
8721 /* reg_namedseq(pRExC_state,UVp, UV depth)
8723 This is expected to be called by a parser routine that has
8724 recognized '\N' and needs to handle the rest. RExC_parse is
8725 expected to point at the first char following the N at the time
8728 The \N may be inside (indicated by valuep not being NULL) or outside a
8731 \N may begin either a named sequence, or if outside a character class, mean
8732 to match a non-newline. For non single-quoted regexes, the tokenizer has
8733 attempted to decide which, and in the case of a named sequence converted it
8734 into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
8735 where c1... are the characters in the sequence. For single-quoted regexes,
8736 the tokenizer passes the \N sequence through unchanged; this code will not
8737 attempt to determine this nor expand those. The net effect is that if the
8738 beginning of the passed-in pattern isn't '{U+' or there is no '}', it
8739 signals that this \N occurrence means to match a non-newline.
8741 Only the \N{U+...} form should occur in a character class, for the same
8742 reason that '.' inside a character class means to just match a period: it
8743 just doesn't make sense.
8745 If valuep is non-null then it is assumed that we are parsing inside
8746 of a charclass definition and the first codepoint in the resolved
8747 string is returned via *valuep and the routine will return NULL.
8748 In this mode if a multichar string is returned from the charnames
8749 handler, a warning will be issued, and only the first char in the
8750 sequence will be examined. If the string returned is zero length
8751 then the value of *valuep is undefined and NON-NULL will
8752 be returned to indicate failure. (This will NOT be a valid pointer
8755 If valuep is null then it is assumed that we are parsing normal text and a
8756 new EXACT node is inserted into the program containing the resolved string,
8757 and a pointer to the new node is returned. But if the string is zero length
8758 a NOTHING node is emitted instead.
8760 On success RExC_parse is set to the char following the endbrace.
8761 Parsing failures will generate a fatal error via vFAIL(...)
8764 S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp, U32 depth)
8766 char * endbrace; /* '}' following the name */
8767 regnode *ret = NULL;
8770 GET_RE_DEBUG_FLAGS_DECL;
8772 PERL_ARGS_ASSERT_REG_NAMEDSEQ;
8776 /* The [^\n] meaning of \N ignores spaces and comments under the /x
8777 * modifier. The other meaning does not */
8778 p = (RExC_flags & RXf_PMf_EXTENDED)
8779 ? regwhite( pRExC_state, RExC_parse )
8782 /* Disambiguate between \N meaning a named character versus \N meaning
8783 * [^\n]. The former is assumed when it can't be the latter. */
8784 if (*p != '{' || regcurly(p)) {
8787 /* no bare \N in a charclass */
8788 vFAIL("\\N in a character class must be a named character: \\N{...}");
8790 nextchar(pRExC_state);
8791 ret = reg_node(pRExC_state, REG_ANY);
8792 *flagp |= HASWIDTH|SIMPLE;
8795 Set_Node_Length(ret, 1); /* MJD */
8799 /* Here, we have decided it should be a named sequence */
8801 /* The test above made sure that the next real character is a '{', but
8802 * under the /x modifier, it could be separated by space (or a comment and
8803 * \n) and this is not allowed (for consistency with \x{...} and the
8804 * tokenizer handling of \N{NAME}). */
8805 if (*RExC_parse != '{') {
8806 vFAIL("Missing braces on \\N{}");
8809 RExC_parse++; /* Skip past the '{' */
8811 if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */
8812 || ! (endbrace == RExC_parse /* nothing between the {} */
8813 || (endbrace - RExC_parse >= 2 /* U+ (bad hex is checked below */
8814 && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) */
8816 if (endbrace) RExC_parse = endbrace; /* position msg's '<--HERE' */
8817 vFAIL("\\N{NAME} must be resolved by the lexer");
8820 if (endbrace == RExC_parse) { /* empty: \N{} */
8822 RExC_parse = endbrace + 1;
8823 return reg_node(pRExC_state,NOTHING);
8827 ckWARNreg(RExC_parse,
8828 "Ignoring zero length \\N{} in character class"
8830 RExC_parse = endbrace + 1;
8833 return (regnode *) &RExC_parse; /* Invalid regnode pointer */
8836 REQUIRE_UTF8; /* named sequences imply Unicode semantics */
8837 RExC_parse += 2; /* Skip past the 'U+' */
8839 if (valuep) { /* In a bracketed char class */
8840 /* We only pay attention to the first char of
8841 multichar strings being returned. I kinda wonder
8842 if this makes sense as it does change the behaviour
8843 from earlier versions, OTOH that behaviour was broken
8844 as well. XXX Solution is to recharacterize as
8845 [rest-of-class]|multi1|multi2... */
8847 STRLEN length_of_hex;
8848 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
8849 | PERL_SCAN_DISALLOW_PREFIX
8850 | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
8852 char * endchar = RExC_parse + strcspn(RExC_parse, ".}");
8853 if (endchar < endbrace) {
8854 ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
8857 length_of_hex = (STRLEN)(endchar - RExC_parse);
8858 *valuep = grok_hex(RExC_parse, &length_of_hex, &flags, NULL);
8860 /* The tokenizer should have guaranteed validity, but it's possible to
8861 * bypass it by using single quoting, so check */
8862 if (length_of_hex == 0
8863 || length_of_hex != (STRLEN)(endchar - RExC_parse) )
8865 RExC_parse += length_of_hex; /* Includes all the valid */
8866 RExC_parse += (RExC_orig_utf8) /* point to after 1st invalid */
8867 ? UTF8SKIP(RExC_parse)
8869 /* Guard against malformed utf8 */
8870 if (RExC_parse >= endchar) RExC_parse = endchar;
8871 vFAIL("Invalid hexadecimal number in \\N{U+...}");
8874 RExC_parse = endbrace + 1;
8875 if (endchar == endbrace) return NULL;
8877 ret = (regnode *) &RExC_parse; /* Invalid regnode pointer */
8879 else { /* Not a char class */
8881 /* What is done here is to convert this to a sub-pattern of the form
8882 * (?:\x{char1}\x{char2}...)
8883 * and then call reg recursively. That way, it retains its atomicness,
8884 * while not having to worry about special handling that some code
8885 * points may have. toke.c has converted the original Unicode values
8886 * to native, so that we can just pass on the hex values unchanged. We
8887 * do have to set a flag to keep recoding from happening in the
8890 SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP);
8892 char *endchar; /* Points to '.' or '}' ending cur char in the input
8894 char *orig_end = RExC_end;
8896 while (RExC_parse < endbrace) {
8898 /* Code points are separated by dots. If none, there is only one
8899 * code point, and is terminated by the brace */
8900 endchar = RExC_parse + strcspn(RExC_parse, ".}");
8902 /* Convert to notation the rest of the code understands */
8903 sv_catpv(substitute_parse, "\\x{");
8904 sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
8905 sv_catpv(substitute_parse, "}");
8907 /* Point to the beginning of the next character in the sequence. */
8908 RExC_parse = endchar + 1;
8910 sv_catpv(substitute_parse, ")");
8912 RExC_parse = SvPV(substitute_parse, len);
8914 /* Don't allow empty number */
8916 vFAIL("Invalid hexadecimal number in \\N{U+...}");
8918 RExC_end = RExC_parse + len;
8920 /* The values are Unicode, and therefore not subject to recoding */
8921 RExC_override_recoding = 1;
8923 ret = reg(pRExC_state, 1, flagp, depth+1);
8925 RExC_parse = endbrace;
8926 RExC_end = orig_end;
8927 RExC_override_recoding = 0;
8929 nextchar(pRExC_state);
8939 * It returns the code point in utf8 for the value in *encp.
8940 * value: a code value in the source encoding
8941 * encp: a pointer to an Encode object
8943 * If the result from Encode is not a single character,
8944 * it returns U+FFFD (Replacement character) and sets *encp to NULL.
8947 S_reg_recode(pTHX_ const char value, SV **encp)
8950 SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
8951 const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
8952 const STRLEN newlen = SvCUR(sv);
8953 UV uv = UNICODE_REPLACEMENT;
8955 PERL_ARGS_ASSERT_REG_RECODE;
8959 ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
8962 if (!newlen || numlen != newlen) {
8963 uv = UNICODE_REPLACEMENT;
8971 - regatom - the lowest level
8973 Try to identify anything special at the start of the pattern. If there
8974 is, then handle it as required. This may involve generating a single regop,
8975 such as for an assertion; or it may involve recursing, such as to
8976 handle a () structure.
8978 If the string doesn't start with something special then we gobble up
8979 as much literal text as we can.
8981 Once we have been able to handle whatever type of thing started the
8982 sequence, we return.
8984 Note: we have to be careful with escapes, as they can be both literal
8985 and special, and in the case of \10 and friends can either, depending
8986 on context. Specifically there are two separate switches for handling
8987 escape sequences, with the one for handling literal escapes requiring
8988 a dummy entry for all of the special escapes that are actually handled
8993 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
8996 register regnode *ret = NULL;
8998 char *parse_start = RExC_parse;
9000 GET_RE_DEBUG_FLAGS_DECL;
9001 DEBUG_PARSE("atom");
9002 *flagp = WORST; /* Tentatively. */
9004 PERL_ARGS_ASSERT_REGATOM;
9007 switch ((U8)*RExC_parse) {
9009 RExC_seen_zerolen++;
9010 nextchar(pRExC_state);
9011 if (RExC_flags & RXf_PMf_MULTILINE)
9012 ret = reg_node(pRExC_state, MBOL);
9013 else if (RExC_flags & RXf_PMf_SINGLELINE)
9014 ret = reg_node(pRExC_state, SBOL);
9016 ret = reg_node(pRExC_state, BOL);
9017 Set_Node_Length(ret, 1); /* MJD */
9020 nextchar(pRExC_state);
9022 RExC_seen_zerolen++;
9023 if (RExC_flags & RXf_PMf_MULTILINE)
9024 ret = reg_node(pRExC_state, MEOL);
9025 else if (RExC_flags & RXf_PMf_SINGLELINE)
9026 ret = reg_node(pRExC_state, SEOL);
9028 ret = reg_node(pRExC_state, EOL);
9029 Set_Node_Length(ret, 1); /* MJD */
9032 nextchar(pRExC_state);
9033 if (RExC_flags & RXf_PMf_SINGLELINE)
9034 ret = reg_node(pRExC_state, SANY);
9036 ret = reg_node(pRExC_state, REG_ANY);
9037 *flagp |= HASWIDTH|SIMPLE;
9039 Set_Node_Length(ret, 1); /* MJD */
9043 char * const oregcomp_parse = ++RExC_parse;
9044 ret = regclass(pRExC_state,depth+1);
9045 if (*RExC_parse != ']') {
9046 RExC_parse = oregcomp_parse;
9047 vFAIL("Unmatched [");
9049 nextchar(pRExC_state);
9050 *flagp |= HASWIDTH|SIMPLE;
9051 Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
9055 nextchar(pRExC_state);
9056 ret = reg(pRExC_state, 1, &flags,depth+1);
9058 if (flags & TRYAGAIN) {
9059 if (RExC_parse == RExC_end) {
9060 /* Make parent create an empty node if needed. */
9068 *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
9072 if (flags & TRYAGAIN) {
9076 vFAIL("Internal urp");
9077 /* Supposed to be caught earlier. */
9080 if (!regcurly(RExC_parse)) {
9089 vFAIL("Quantifier follows nothing");
9094 This switch handles escape sequences that resolve to some kind
9095 of special regop and not to literal text. Escape sequnces that
9096 resolve to literal text are handled below in the switch marked
9099 Every entry in this switch *must* have a corresponding entry
9100 in the literal escape switch. However, the opposite is not
9101 required, as the default for this switch is to jump to the
9102 literal text handling code.
9104 switch ((U8)*++RExC_parse) {
9105 /* Special Escapes */
9107 RExC_seen_zerolen++;
9108 ret = reg_node(pRExC_state, SBOL);
9110 goto finish_meta_pat;
9112 ret = reg_node(pRExC_state, GPOS);
9113 RExC_seen |= REG_SEEN_GPOS;
9115 goto finish_meta_pat;
9117 RExC_seen_zerolen++;
9118 ret = reg_node(pRExC_state, KEEPS);
9120 /* XXX:dmq : disabling in-place substitution seems to
9121 * be necessary here to avoid cases of memory corruption, as
9122 * with: C<$_="x" x 80; s/x\K/y/> -- rgs
9124 RExC_seen |= REG_SEEN_LOOKBEHIND;
9125 goto finish_meta_pat;
9127 ret = reg_node(pRExC_state, SEOL);
9129 RExC_seen_zerolen++; /* Do not optimize RE away */
9130 goto finish_meta_pat;
9132 ret = reg_node(pRExC_state, EOS);
9134 RExC_seen_zerolen++; /* Do not optimize RE away */
9135 goto finish_meta_pat;
9137 ret = reg_node(pRExC_state, CANY);
9138 RExC_seen |= REG_SEEN_CANY;
9139 *flagp |= HASWIDTH|SIMPLE;
9140 goto finish_meta_pat;
9142 ret = reg_node(pRExC_state, CLUMP);
9144 goto finish_meta_pat;
9146 switch (get_regex_charset(RExC_flags)) {
9147 case REGEX_LOCALE_CHARSET:
9150 case REGEX_UNICODE_CHARSET:
9153 case REGEX_ASCII_RESTRICTED_CHARSET:
9154 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9157 case REGEX_DEPENDS_CHARSET:
9163 ret = reg_node(pRExC_state, op);
9164 *flagp |= HASWIDTH|SIMPLE;
9165 goto finish_meta_pat;
9167 switch (get_regex_charset(RExC_flags)) {
9168 case REGEX_LOCALE_CHARSET:
9171 case REGEX_UNICODE_CHARSET:
9174 case REGEX_ASCII_RESTRICTED_CHARSET:
9175 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9178 case REGEX_DEPENDS_CHARSET:
9184 ret = reg_node(pRExC_state, op);
9185 *flagp |= HASWIDTH|SIMPLE;
9186 goto finish_meta_pat;
9188 RExC_seen_zerolen++;
9189 RExC_seen |= REG_SEEN_LOOKBEHIND;
9190 switch (get_regex_charset(RExC_flags)) {
9191 case REGEX_LOCALE_CHARSET:
9194 case REGEX_UNICODE_CHARSET:
9197 case REGEX_ASCII_RESTRICTED_CHARSET:
9198 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9201 case REGEX_DEPENDS_CHARSET:
9207 ret = reg_node(pRExC_state, op);
9208 FLAGS(ret) = get_regex_charset(RExC_flags);
9210 if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
9211 ckWARNregdep(RExC_parse, "\"\\b{\" is deprecated; use \"\\b\\{\" instead");
9213 goto finish_meta_pat;
9215 RExC_seen_zerolen++;
9216 RExC_seen |= REG_SEEN_LOOKBEHIND;
9217 switch (get_regex_charset(RExC_flags)) {
9218 case REGEX_LOCALE_CHARSET:
9221 case REGEX_UNICODE_CHARSET:
9224 case REGEX_ASCII_RESTRICTED_CHARSET:
9225 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9228 case REGEX_DEPENDS_CHARSET:
9234 ret = reg_node(pRExC_state, op);
9235 FLAGS(ret) = get_regex_charset(RExC_flags);
9237 if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
9238 ckWARNregdep(RExC_parse, "\"\\B{\" is deprecated; use \"\\B\\{\" instead");
9240 goto finish_meta_pat;
9242 switch (get_regex_charset(RExC_flags)) {
9243 case REGEX_LOCALE_CHARSET:
9246 case REGEX_UNICODE_CHARSET:
9249 case REGEX_ASCII_RESTRICTED_CHARSET:
9250 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9253 case REGEX_DEPENDS_CHARSET:
9259 ret = reg_node(pRExC_state, op);
9260 *flagp |= HASWIDTH|SIMPLE;
9261 goto finish_meta_pat;
9263 switch (get_regex_charset(RExC_flags)) {
9264 case REGEX_LOCALE_CHARSET:
9267 case REGEX_UNICODE_CHARSET:
9270 case REGEX_ASCII_RESTRICTED_CHARSET:
9271 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9274 case REGEX_DEPENDS_CHARSET:
9280 ret = reg_node(pRExC_state, op);
9281 *flagp |= HASWIDTH|SIMPLE;
9282 goto finish_meta_pat;
9284 switch (get_regex_charset(RExC_flags)) {
9285 case REGEX_LOCALE_CHARSET:
9288 case REGEX_ASCII_RESTRICTED_CHARSET:
9289 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9292 case REGEX_DEPENDS_CHARSET: /* No difference between these */
9293 case REGEX_UNICODE_CHARSET:
9299 ret = reg_node(pRExC_state, op);
9300 *flagp |= HASWIDTH|SIMPLE;
9301 goto finish_meta_pat;
9303 switch (get_regex_charset(RExC_flags)) {
9304 case REGEX_LOCALE_CHARSET:
9307 case REGEX_ASCII_RESTRICTED_CHARSET:
9308 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9311 case REGEX_DEPENDS_CHARSET: /* No difference between these */
9312 case REGEX_UNICODE_CHARSET:
9318 ret = reg_node(pRExC_state, op);
9319 *flagp |= HASWIDTH|SIMPLE;
9320 goto finish_meta_pat;
9322 ret = reg_node(pRExC_state, LNBREAK);
9323 *flagp |= HASWIDTH|SIMPLE;
9324 goto finish_meta_pat;
9326 ret = reg_node(pRExC_state, HORIZWS);
9327 *flagp |= HASWIDTH|SIMPLE;
9328 goto finish_meta_pat;
9330 ret = reg_node(pRExC_state, NHORIZWS);
9331 *flagp |= HASWIDTH|SIMPLE;
9332 goto finish_meta_pat;
9334 ret = reg_node(pRExC_state, VERTWS);
9335 *flagp |= HASWIDTH|SIMPLE;
9336 goto finish_meta_pat;
9338 ret = reg_node(pRExC_state, NVERTWS);
9339 *flagp |= HASWIDTH|SIMPLE;
9341 nextchar(pRExC_state);
9342 Set_Node_Length(ret, 2); /* MJD */
9347 char* const oldregxend = RExC_end;
9349 char* parse_start = RExC_parse - 2;
9352 if (RExC_parse[1] == '{') {
9353 /* a lovely hack--pretend we saw [\pX] instead */
9354 RExC_end = strchr(RExC_parse, '}');
9356 const U8 c = (U8)*RExC_parse;
9358 RExC_end = oldregxend;
9359 vFAIL2("Missing right brace on \\%c{}", c);
9364 RExC_end = RExC_parse + 2;
9365 if (RExC_end > oldregxend)
9366 RExC_end = oldregxend;
9370 ret = regclass(pRExC_state,depth+1);
9372 RExC_end = oldregxend;
9375 Set_Node_Offset(ret, parse_start + 2);
9376 Set_Node_Cur_Length(ret);
9377 nextchar(pRExC_state);
9378 *flagp |= HASWIDTH|SIMPLE;
9382 /* Handle \N and \N{NAME} here and not below because it can be
9383 multicharacter. join_exact() will join them up later on.
9384 Also this makes sure that things like /\N{BLAH}+/ and
9385 \N{BLAH} being multi char Just Happen. dmq*/
9387 ret= reg_namedseq(pRExC_state, NULL, flagp, depth);
9389 case 'k': /* Handle \k<NAME> and \k'NAME' */
9392 char ch= RExC_parse[1];
9393 if (ch != '<' && ch != '\'' && ch != '{') {
9395 vFAIL2("Sequence %.2s... not terminated",parse_start);
9397 /* this pretty much dupes the code for (?P=...) in reg(), if
9398 you change this make sure you change that */
9399 char* name_start = (RExC_parse += 2);
9401 SV *sv_dat = reg_scan_name(pRExC_state,
9402 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
9403 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
9404 if (RExC_parse == name_start || *RExC_parse != ch)
9405 vFAIL2("Sequence %.3s... not terminated",parse_start);
9408 num = add_data( pRExC_state, 1, "S" );
9409 RExC_rxi->data->data[num]=(void*)sv_dat;
9410 SvREFCNT_inc_simple_void(sv_dat);
9414 ret = reganode(pRExC_state,
9417 : (MORE_ASCII_RESTRICTED)
9419 : (AT_LEAST_UNI_SEMANTICS)
9427 /* override incorrect value set in reganode MJD */
9428 Set_Node_Offset(ret, parse_start+1);
9429 Set_Node_Cur_Length(ret); /* MJD */
9430 nextchar(pRExC_state);
9436 case '1': case '2': case '3': case '4':
9437 case '5': case '6': case '7': case '8': case '9':
9440 bool isg = *RExC_parse == 'g';
9445 if (*RExC_parse == '{') {
9449 if (*RExC_parse == '-') {
9453 if (hasbrace && !isDIGIT(*RExC_parse)) {
9454 if (isrel) RExC_parse--;
9456 goto parse_named_seq;
9458 num = atoi(RExC_parse);
9459 if (isg && num == 0)
9460 vFAIL("Reference to invalid group 0");
9462 num = RExC_npar - num;
9464 vFAIL("Reference to nonexistent or unclosed group");
9466 if (!isg && num > 9 && num >= RExC_npar)
9469 char * const parse_start = RExC_parse - 1; /* MJD */
9470 while (isDIGIT(*RExC_parse))
9472 if (parse_start == RExC_parse - 1)
9473 vFAIL("Unterminated \\g... pattern");
9475 if (*RExC_parse != '}')
9476 vFAIL("Unterminated \\g{...} pattern");
9480 if (num > (I32)RExC_rx->nparens)
9481 vFAIL("Reference to nonexistent group");
9484 ret = reganode(pRExC_state,
9487 : (MORE_ASCII_RESTRICTED)
9489 : (AT_LEAST_UNI_SEMANTICS)
9497 /* override incorrect value set in reganode MJD */
9498 Set_Node_Offset(ret, parse_start+1);
9499 Set_Node_Cur_Length(ret); /* MJD */
9501 nextchar(pRExC_state);
9506 if (RExC_parse >= RExC_end)
9507 FAIL("Trailing \\");
9510 /* Do not generate "unrecognized" warnings here, we fall
9511 back into the quick-grab loop below */
9518 if (RExC_flags & RXf_PMf_EXTENDED) {
9519 if ( reg_skipcomment( pRExC_state ) )
9526 parse_start = RExC_parse - 1;
9531 register STRLEN len;
9536 U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
9539 /* Is this a LATIN LOWER CASE SHARP S in an EXACTFU node? If so,
9540 * it is folded to 'ss' even if not utf8 */
9541 bool is_exactfu_sharp_s;
9544 node_type = ((! FOLD) ? EXACT
9547 : (MORE_ASCII_RESTRICTED)
9549 : (AT_LEAST_UNI_SEMANTICS)
9552 ret = reg_node(pRExC_state, node_type);
9555 /* XXX The node can hold up to 255 bytes, yet this only goes to
9556 * 127. I (khw) do not know why. Keeping it somewhat less than
9557 * 255 allows us to not have to worry about overflow due to
9558 * converting to utf8 and fold expansion, but that value is
9559 * 255-UTF8_MAXBYTES_CASE. join_exact() may join adjacent nodes
9560 * split up by this limit into a single one using the real max of
9561 * 255. Even at 127, this breaks under rare circumstances. If
9562 * folding, we do not want to split a node at a character that is a
9563 * non-final in a multi-char fold, as an input string could just
9564 * happen to want to match across the node boundary. The join
9565 * would solve that problem if the join actually happens. But a
9566 * series of more than two nodes in a row each of 127 would cause
9567 * the first join to succeed to get to 254, but then there wouldn't
9568 * be room for the next one, which could at be one of those split
9569 * multi-char folds. I don't know of any fool-proof solution. One
9570 * could back off to end with only a code point that isn't such a
9571 * non-final, but it is possible for there not to be any in the
9573 for (len = 0, p = RExC_parse - 1;
9574 len < 127 && p < RExC_end;
9577 char * const oldp = p;
9579 if (RExC_flags & RXf_PMf_EXTENDED)
9580 p = regwhite( pRExC_state, p );
9591 /* Literal Escapes Switch
9593 This switch is meant to handle escape sequences that
9594 resolve to a literal character.
9596 Every escape sequence that represents something
9597 else, like an assertion or a char class, is handled
9598 in the switch marked 'Special Escapes' above in this
9599 routine, but also has an entry here as anything that
9600 isn't explicitly mentioned here will be treated as
9601 an unescaped equivalent literal.
9605 /* These are all the special escapes. */
9606 case 'A': /* Start assertion */
9607 case 'b': case 'B': /* Word-boundary assertion*/
9608 case 'C': /* Single char !DANGEROUS! */
9609 case 'd': case 'D': /* digit class */
9610 case 'g': case 'G': /* generic-backref, pos assertion */
9611 case 'h': case 'H': /* HORIZWS */
9612 case 'k': case 'K': /* named backref, keep marker */
9613 case 'N': /* named char sequence */
9614 case 'p': case 'P': /* Unicode property */
9615 case 'R': /* LNBREAK */
9616 case 's': case 'S': /* space class */
9617 case 'v': case 'V': /* VERTWS */
9618 case 'w': case 'W': /* word class */
9619 case 'X': /* eXtended Unicode "combining character sequence" */
9620 case 'z': case 'Z': /* End of line/string assertion */
9624 /* Anything after here is an escape that resolves to a
9625 literal. (Except digits, which may or may not)
9644 ender = ASCII_TO_NATIVE('\033');
9648 ender = ASCII_TO_NATIVE('\007');
9653 STRLEN brace_len = len;
9655 const char* error_msg;
9657 bool valid = grok_bslash_o(p,
9664 RExC_parse = p; /* going to die anyway; point
9665 to exact spot of failure */
9672 if (PL_encoding && ender < 0x100) {
9673 goto recode_encoding;
9682 char* const e = strchr(p, '}');
9686 vFAIL("Missing right brace on \\x{}");
9689 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
9690 | PERL_SCAN_DISALLOW_PREFIX;
9691 STRLEN numlen = e - p - 1;
9692 ender = grok_hex(p + 1, &numlen, &flags, NULL);
9699 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
9701 ender = grok_hex(p, &numlen, &flags, NULL);
9704 if (PL_encoding && ender < 0x100)
9705 goto recode_encoding;
9709 ender = grok_bslash_c(*p++, UTF, SIZE_ONLY);
9711 case '0': case '1': case '2': case '3':case '4':
9712 case '5': case '6': case '7': case '8':case '9':
9714 (isDIGIT(p[1]) && atoi(p) >= RExC_npar))
9716 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
9718 ender = grok_oct(p, &numlen, &flags, NULL);
9728 if (PL_encoding && ender < 0x100)
9729 goto recode_encoding;
9732 if (! RExC_override_recoding) {
9733 SV* enc = PL_encoding;
9734 ender = reg_recode((const char)(U8)ender, &enc);
9735 if (!enc && SIZE_ONLY)
9736 ckWARNreg(p, "Invalid escape in the specified encoding");
9742 FAIL("Trailing \\");
9745 if (!SIZE_ONLY&& isALPHA(*p)) {
9746 /* Include any { following the alpha to emphasize
9747 * that it could be part of an escape at some point
9749 int len = (*(p + 1) == '{') ? 2 : 1;
9750 ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
9752 goto normal_default;
9757 if (UTF8_IS_START(*p) && UTF) {
9759 ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
9760 &numlen, UTF8_ALLOW_DEFAULT);
9766 } /* End of switch on the literal */
9768 is_exactfu_sharp_s = (node_type == EXACTFU
9769 && ender == LATIN_SMALL_LETTER_SHARP_S);
9770 if ( RExC_flags & RXf_PMf_EXTENDED)
9771 p = regwhite( pRExC_state, p );
9772 if ((UTF && FOLD) || is_exactfu_sharp_s) {
9773 /* Prime the casefolded buffer. Locale rules, which apply
9774 * only to code points < 256, aren't known until execution,
9775 * so for them, just output the original character using
9776 * utf8. If we start to fold non-UTF patterns, be sure to
9777 * update join_exact() */
9778 if (LOC && ender < 256) {
9779 if (UNI_IS_INVARIANT(ender)) {
9780 *tmpbuf = (U8) ender;
9783 *tmpbuf = UTF8_TWO_BYTE_HI(ender);
9784 *(tmpbuf + 1) = UTF8_TWO_BYTE_LO(ender);
9788 else if (isASCII(ender)) { /* Note: Here can't also be LOC
9790 ender = toLOWER(ender);
9791 *tmpbuf = (U8) ender;
9794 else if (! MORE_ASCII_RESTRICTED && ! LOC) {
9796 /* Locale and /aa require more selectivity about the
9797 * fold, so are handled below. Otherwise, here, just
9799 ender = toFOLD_uni(ender, tmpbuf, &foldlen);
9802 /* Under locale rules or /aa we are not to mix,
9803 * respectively, ords < 256 or ASCII with non-. So
9804 * reject folds that mix them, using only the
9805 * non-folded code point. So do the fold to a
9806 * temporary, and inspect each character in it. */
9807 U8 trialbuf[UTF8_MAXBYTES_CASE+1];
9809 UV tmpender = toFOLD_uni(ender, trialbuf, &foldlen);
9810 U8* e = s + foldlen;
9811 bool fold_ok = TRUE;
9815 || (LOC && (UTF8_IS_INVARIANT(*s)
9816 || UTF8_IS_DOWNGRADEABLE_START(*s))))
9824 Copy(trialbuf, tmpbuf, foldlen, U8);
9828 uvuni_to_utf8(tmpbuf, ender);
9829 foldlen = UNISKIP(ender);
9833 if (p < RExC_end && ISMULT2(p)) { /* Back off on ?+*. */
9836 else if (UTF || is_exactfu_sharp_s) {
9838 /* Emit all the Unicode characters. */
9840 for (foldbuf = tmpbuf;
9842 foldlen -= numlen) {
9844 /* tmpbuf has been constructed by us, so we
9845 * know it is valid utf8 */
9846 ender = valid_utf8_to_uvchr(foldbuf, &numlen);
9848 const STRLEN unilen = reguni(pRExC_state, ender, s);
9851 /* In EBCDIC the numlen
9852 * and unilen can differ. */
9854 if (numlen >= foldlen)
9858 break; /* "Can't happen." */
9862 const STRLEN unilen = reguni(pRExC_state, ender, s);
9871 REGC((char)ender, s++);
9875 if (UTF || is_exactfu_sharp_s) {
9877 /* Emit all the Unicode characters. */
9879 for (foldbuf = tmpbuf;
9881 foldlen -= numlen) {
9882 ender = valid_utf8_to_uvchr(foldbuf, &numlen);
9884 const STRLEN unilen = reguni(pRExC_state, ender, s);
9887 /* In EBCDIC the numlen
9888 * and unilen can differ. */
9890 if (numlen >= foldlen)
9898 const STRLEN unilen = reguni(pRExC_state, ender, s);
9907 REGC((char)ender, s++);
9910 loopdone: /* Jumped to when encounters something that shouldn't be in
9913 Set_Node_Cur_Length(ret); /* MJD */
9914 nextchar(pRExC_state);
9916 /* len is STRLEN which is unsigned, need to copy to signed */
9919 vFAIL("Internal disaster");
9923 if (len == 1 && UNI_IS_INVARIANT(ender))
9927 RExC_size += STR_SZ(len);
9930 RExC_emit += STR_SZ(len);
9938 /* Jumped to when an unrecognized character set is encountered */
9940 Perl_croak(aTHX_ "panic: Unknown regex character set encoding: %u", get_regex_charset(RExC_flags));
9945 S_regwhite( RExC_state_t *pRExC_state, char *p )
9947 const char *e = RExC_end;
9949 PERL_ARGS_ASSERT_REGWHITE;
9954 else if (*p == '#') {
9963 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
9971 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
9972 Character classes ([:foo:]) can also be negated ([:^foo:]).
9973 Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
9974 Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
9975 but trigger failures because they are currently unimplemented. */
9977 #define POSIXCC_DONE(c) ((c) == ':')
9978 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
9979 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
9982 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
9985 I32 namedclass = OOB_NAMEDCLASS;
9987 PERL_ARGS_ASSERT_REGPPOSIXCC;
9989 if (value == '[' && RExC_parse + 1 < RExC_end &&
9990 /* I smell either [: or [= or [. -- POSIX has been here, right? */
9991 POSIXCC(UCHARAT(RExC_parse))) {
9992 const char c = UCHARAT(RExC_parse);
9993 char* const s = RExC_parse++;
9995 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
9997 if (RExC_parse == RExC_end)
9998 /* Grandfather lone [:, [=, [. */
10001 const char* const t = RExC_parse++; /* skip over the c */
10004 if (UCHARAT(RExC_parse) == ']') {
10005 const char *posixcc = s + 1;
10006 RExC_parse++; /* skip over the ending ] */
10009 const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
10010 const I32 skip = t - posixcc;
10012 /* Initially switch on the length of the name. */
10015 if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
10016 namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
10019 /* Names all of length 5. */
10020 /* alnum alpha ascii blank cntrl digit graph lower
10021 print punct space upper */
10022 /* Offset 4 gives the best switch position. */
10023 switch (posixcc[4]) {
10025 if (memEQ(posixcc, "alph", 4)) /* alpha */
10026 namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
10029 if (memEQ(posixcc, "spac", 4)) /* space */
10030 namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
10033 if (memEQ(posixcc, "grap", 4)) /* graph */
10034 namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
10037 if (memEQ(posixcc, "asci", 4)) /* ascii */
10038 namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
10041 if (memEQ(posixcc, "blan", 4)) /* blank */
10042 namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
10045 if (memEQ(posixcc, "cntr", 4)) /* cntrl */
10046 namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
10049 if (memEQ(posixcc, "alnu", 4)) /* alnum */
10050 namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
10053 if (memEQ(posixcc, "lowe", 4)) /* lower */
10054 namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
10055 else if (memEQ(posixcc, "uppe", 4)) /* upper */
10056 namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
10059 if (memEQ(posixcc, "digi", 4)) /* digit */
10060 namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
10061 else if (memEQ(posixcc, "prin", 4)) /* print */
10062 namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
10063 else if (memEQ(posixcc, "punc", 4)) /* punct */
10064 namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
10069 if (memEQ(posixcc, "xdigit", 6))
10070 namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
10074 if (namedclass == OOB_NAMEDCLASS)
10075 Simple_vFAIL3("POSIX class [:%.*s:] unknown",
10077 assert (posixcc[skip] == ':');
10078 assert (posixcc[skip+1] == ']');
10079 } else if (!SIZE_ONLY) {
10080 /* [[=foo=]] and [[.foo.]] are still future. */
10082 /* adjust RExC_parse so the warning shows after
10083 the class closes */
10084 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
10086 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
10089 /* Maternal grandfather:
10090 * "[:" ending in ":" but not in ":]" */
10100 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
10104 PERL_ARGS_ASSERT_CHECKPOSIXCC;
10106 if (POSIXCC(UCHARAT(RExC_parse))) {
10107 const char *s = RExC_parse;
10108 const char c = *s++;
10110 while (isALNUM(*s))
10112 if (*s && c == *s && s[1] == ']') {
10114 "POSIX syntax [%c %c] belongs inside character classes",
10117 /* [[=foo=]] and [[.foo.]] are still future. */
10118 if (POSIXCC_NOTYET(c)) {
10119 /* adjust RExC_parse so the error shows after
10120 the class closes */
10121 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
10123 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
10129 /* Generate the code to add a full posix character <class> to the bracketed
10130 * character class given by <node>. (<node> is needed only under locale rules)
10131 * destlist is the inversion list for non-locale rules that this class is
10133 * sourcelist is the ASCII-range inversion list to add under /a rules
10134 * Xsourcelist is the full Unicode range list to use otherwise. */
10135 #define DO_POSIX(node, class, destlist, sourcelist, Xsourcelist) \
10137 SV* scratch_list = NULL; \
10139 /* Set this class in the node for runtime matching */ \
10140 ANYOF_CLASS_SET(node, class); \
10142 /* For above Latin1 code points, we use the full Unicode range */ \
10143 _invlist_intersection(PL_AboveLatin1, \
10146 /* And set the output to it, adding instead if there already is an \
10147 * output. Checking if <destlist> is NULL first saves an extra \
10148 * clone. Its reference count will be decremented at the next \
10149 * union, etc, or if this is the only instance, at the end of the \
10151 if (! destlist) { \
10152 destlist = scratch_list; \
10155 _invlist_union(destlist, scratch_list, &destlist); \
10156 SvREFCNT_dec(scratch_list); \
10160 /* For non-locale, just add it to any existing list */ \
10161 _invlist_union(destlist, \
10162 (AT_LEAST_ASCII_RESTRICTED) \
10168 /* Like DO_POSIX, but matches the complement of <sourcelist> and <Xsourcelist>.
10170 #define DO_N_POSIX(node, class, destlist, sourcelist, Xsourcelist) \
10172 SV* scratch_list = NULL; \
10173 ANYOF_CLASS_SET(node, class); \
10174 _invlist_subtract(PL_AboveLatin1, Xsourcelist, &scratch_list); \
10175 if (! destlist) { \
10176 destlist = scratch_list; \
10179 _invlist_union(destlist, scratch_list, &destlist); \
10180 SvREFCNT_dec(scratch_list); \
10184 _invlist_union_complement_2nd(destlist, \
10185 (AT_LEAST_ASCII_RESTRICTED) \
10189 /* Under /d, everything in the upper half of the Latin1 range \
10190 * matches this complement */ \
10191 if (DEPENDS_SEMANTICS) { \
10192 ANYOF_FLAGS(node) |= ANYOF_NON_UTF8_LATIN1_ALL; \
10196 /* Generate the code to add a posix character <class> to the bracketed
10197 * character class given by <node>. (<node> is needed only under locale rules)
10198 * destlist is the inversion list for non-locale rules that this class is
10200 * sourcelist is the ASCII-range inversion list to add under /a rules
10201 * l1_sourcelist is the Latin1 range list to use otherwise.
10202 * Xpropertyname is the name to add to <run_time_list> of the property to
10203 * specify the code points above Latin1 that will have to be
10204 * determined at run-time
10205 * run_time_list is a SV* that contains text names of properties that are to
10206 * be computed at run time. This concatenates <Xpropertyname>
10207 * to it, apppropriately
10208 * This is essentially DO_POSIX, but we know only the Latin1 values at compile
10210 #define DO_POSIX_LATIN1_ONLY_KNOWN(node, class, destlist, sourcelist, \
10211 l1_sourcelist, Xpropertyname, run_time_list) \
10212 /* If not /a matching, there are going to be code points we will have \
10213 * to defer to runtime to look-up */ \
10214 if (! AT_LEAST_ASCII_RESTRICTED) { \
10215 Perl_sv_catpvf(aTHX_ run_time_list, "+utf8::%s\n", Xpropertyname); \
10218 ANYOF_CLASS_SET(node, class); \
10221 _invlist_union(destlist, \
10222 (AT_LEAST_ASCII_RESTRICTED) \
10228 /* Like DO_POSIX_LATIN1_ONLY_KNOWN, but for the complement. A combination of
10229 * this and DO_N_POSIX */
10230 #define DO_N_POSIX_LATIN1_ONLY_KNOWN(node, class, destlist, sourcelist, \
10231 l1_sourcelist, Xpropertyname, run_time_list) \
10232 if (AT_LEAST_ASCII_RESTRICTED) { \
10233 _invlist_union_complement_2nd(destlist, sourcelist, &destlist); \
10236 Perl_sv_catpvf(aTHX_ run_time_list, "!utf8::%s\n", Xpropertyname); \
10238 ANYOF_CLASS_SET(node, namedclass); \
10241 SV* scratch_list = NULL; \
10242 _invlist_subtract(PL_Latin1, l1_sourcelist, &scratch_list); \
10243 if (! destlist) { \
10244 destlist = scratch_list; \
10247 _invlist_union(destlist, scratch_list, &destlist); \
10248 SvREFCNT_dec(scratch_list); \
10250 if (DEPENDS_SEMANTICS) { \
10251 ANYOF_FLAGS(node) |= ANYOF_NON_UTF8_LATIN1_ALL; \
10257 S_set_regclass_bit_fold(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, SV** invlist_ptr, AV** alternate_ptr)
10260 /* Handle the setting of folds in the bitmap for non-locale ANYOF nodes.
10261 * Locale folding is done at run-time, so this function should not be
10262 * called for nodes that are for locales.
10264 * This function sets the bit corresponding to the fold of the input
10265 * 'value', if not already set. The fold of 'f' is 'F', and the fold of
10268 * It also knows about the characters that are in the bitmap that have
10269 * folds that are matchable only outside it, and sets the appropriate lists
10272 * It returns the number of bits that actually changed from 0 to 1 */
10277 PERL_ARGS_ASSERT_SET_REGCLASS_BIT_FOLD;
10279 fold = (AT_LEAST_UNI_SEMANTICS) ? PL_fold_latin1[value]
10282 /* It assumes the bit for 'value' has already been set */
10283 if (fold != value && ! ANYOF_BITMAP_TEST(node, fold)) {
10284 ANYOF_BITMAP_SET(node, fold);
10287 if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value) && (! isASCII(value) || ! MORE_ASCII_RESTRICTED)) {
10288 /* Certain Latin1 characters have matches outside the bitmap. To get
10289 * here, 'value' is one of those characters. None of these matches is
10290 * valid for ASCII characters under /aa, which have been excluded by
10291 * the 'if' above. The matches fall into three categories:
10292 * 1) They are singly folded-to or -from an above 255 character, as
10293 * LATIN SMALL LETTER Y WITH DIAERESIS and LATIN CAPITAL LETTER Y
10295 * 2) They are part of a multi-char fold with another character in the
10296 * bitmap, only LATIN SMALL LETTER SHARP S => "ss" fits that bill;
10297 * 3) They are part of a multi-char fold with a character not in the
10298 * bitmap, such as various ligatures.
10299 * We aren't dealing fully with multi-char folds, except we do deal
10300 * with the pattern containing a character that has a multi-char fold
10301 * (not so much the inverse).
10302 * For types 1) and 3), the matches only happen when the target string
10303 * is utf8; that's not true for 2), and we set a flag for it.
10305 * The code below adds to the passed in inversion list the single fold
10306 * closures for 'value'. The values are hard-coded here so that an
10307 * innocent-looking character class, like /[ks]/i won't have to go out
10308 * to disk to find the possible matches. XXX It would be better to
10309 * generate these via regen, in case a new version of the Unicode
10310 * standard adds new mappings, though that is not really likely. */
10315 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212A);
10319 /* LATIN SMALL LETTER LONG S */
10320 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x017F);
10323 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10324 GREEK_SMALL_LETTER_MU);
10325 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10326 GREEK_CAPITAL_LETTER_MU);
10328 case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
10329 case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
10330 /* ANGSTROM SIGN */
10331 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212B);
10332 if (DEPENDS_SEMANTICS) { /* See DEPENDS comment below */
10333 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10334 PL_fold_latin1[value]);
10337 case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
10338 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10339 LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
10341 case LATIN_SMALL_LETTER_SHARP_S:
10342 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10343 LATIN_CAPITAL_LETTER_SHARP_S);
10345 /* Under /a, /d, and /u, this can match the two chars "ss" */
10346 if (! MORE_ASCII_RESTRICTED) {
10347 add_alternate(alternate_ptr, (U8 *) "ss", 2);
10349 /* And under /u or /a, it can match even if the target is
10351 if (AT_LEAST_UNI_SEMANTICS) {
10352 ANYOF_FLAGS(node) |= ANYOF_NONBITMAP_NON_UTF8;
10356 case 'F': case 'f':
10357 case 'I': case 'i':
10358 case 'L': case 'l':
10359 case 'T': case 't':
10360 case 'A': case 'a':
10361 case 'H': case 'h':
10362 case 'J': case 'j':
10363 case 'N': case 'n':
10364 case 'W': case 'w':
10365 case 'Y': case 'y':
10366 /* These all are targets of multi-character folds from code
10367 * points that require UTF8 to express, so they can't match
10368 * unless the target string is in UTF-8, so no action here is
10369 * necessary, as regexec.c properly handles the general case
10370 * for UTF-8 matching */
10373 /* Use deprecated warning to increase the chances of this
10375 ckWARN2regdep(RExC_parse, "Perl folding rules are not up-to-date for 0x%x; please use the perlbug utility to report;", value);
10379 else if (DEPENDS_SEMANTICS
10380 && ! isASCII(value)
10381 && PL_fold_latin1[value] != value)
10383 /* Under DEPENDS rules, non-ASCII Latin1 characters match their
10384 * folds only when the target string is in UTF-8. We add the fold
10385 * here to the list of things to match outside the bitmap, which
10386 * won't be looked at unless it is UTF8 (or else if something else
10387 * says to look even if not utf8, but those things better not happen
10388 * under DEPENDS semantics. */
10389 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, PL_fold_latin1[value]);
10396 PERL_STATIC_INLINE U8
10397 S_set_regclass_bit(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, SV** invlist_ptr, AV** alternate_ptr)
10399 /* This inline function sets a bit in the bitmap if not already set, and if
10400 * appropriate, its fold, returning the number of bits that actually
10401 * changed from 0 to 1 */
10405 PERL_ARGS_ASSERT_SET_REGCLASS_BIT;
10407 if (ANYOF_BITMAP_TEST(node, value)) { /* Already set */
10411 ANYOF_BITMAP_SET(node, value);
10414 if (FOLD && ! LOC) { /* Locale folds aren't known until runtime */
10415 stored += set_regclass_bit_fold(pRExC_state, node, value, invlist_ptr, alternate_ptr);
10422 S_add_alternate(pTHX_ AV** alternate_ptr, U8* string, STRLEN len)
10424 /* Adds input 'string' with length 'len' to the ANYOF node's unicode
10425 * alternate list, pointed to by 'alternate_ptr'. This is an array of
10426 * the multi-character folds of characters in the node */
10429 PERL_ARGS_ASSERT_ADD_ALTERNATE;
10431 if (! *alternate_ptr) {
10432 *alternate_ptr = newAV();
10434 sv = newSVpvn_utf8((char*)string, len, TRUE);
10435 av_push(*alternate_ptr, sv);
10440 parse a class specification and produce either an ANYOF node that
10441 matches the pattern or perhaps will be optimized into an EXACTish node
10442 instead. The node contains a bit map for the first 256 characters, with the
10443 corresponding bit set if that character is in the list. For characters
10444 above 255, a range list is used */
10447 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
10450 register UV nextvalue;
10451 register IV prevvalue = OOB_UNICODE;
10452 register IV range = 0;
10453 UV value = 0; /* XXX:dmq: needs to be referenceable (unfortunately) */
10454 register regnode *ret;
10457 char *rangebegin = NULL;
10458 bool need_class = 0;
10459 bool allow_full_fold = TRUE; /* Assume wants multi-char folding */
10461 STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
10462 than just initialized. */
10463 SV* properties = NULL; /* Code points that match \p{} \P{} */
10464 UV element_count = 0; /* Number of distinct elements in the class.
10465 Optimizations may be possible if this is tiny */
10468 /* Unicode properties are stored in a swash; this holds the current one
10469 * being parsed. If this swash is the only above-latin1 component of the
10470 * character class, an optimization is to pass it directly on to the
10471 * execution engine. Otherwise, it is set to NULL to indicate that there
10472 * are other things in the class that have to be dealt with at execution
10474 SV* swash = NULL; /* Code points that match \p{} \P{} */
10476 /* Set if a component of this character class is user-defined; just passed
10477 * on to the engine */
10478 UV has_user_defined_property = 0;
10480 /* code points this node matches that can't be stored in the bitmap */
10481 SV* nonbitmap = NULL;
10483 /* The items that are to match that aren't stored in the bitmap, but are a
10484 * result of things that are stored there. This is the fold closure of
10485 * such a character, either because it has DEPENDS semantics and shouldn't
10486 * be matched unless the target string is utf8, or is a code point that is
10487 * too large for the bit map, as for example, the fold of the MICRO SIGN is
10488 * above 255. This all is solely for performance reasons. By having this
10489 * code know the outside-the-bitmap folds that the bitmapped characters are
10490 * involved with, we don't have to go out to disk to find the list of
10491 * matches, unless the character class includes code points that aren't
10492 * storable in the bit map. That means that a character class with an 's'
10493 * in it, for example, doesn't need to go out to disk to find everything
10494 * that matches. A 2nd list is used so that the 'nonbitmap' list is kept
10495 * empty unless there is something whose fold we don't know about, and will
10496 * have to go out to the disk to find. */
10497 SV* l1_fold_invlist = NULL;
10499 /* List of multi-character folds that are matched by this node */
10500 AV* unicode_alternate = NULL;
10502 UV literal_endpoint = 0;
10504 UV stored = 0; /* how many chars stored in the bitmap */
10506 regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
10507 case we need to change the emitted regop to an EXACT. */
10508 const char * orig_parse = RExC_parse;
10509 GET_RE_DEBUG_FLAGS_DECL;
10511 PERL_ARGS_ASSERT_REGCLASS;
10513 PERL_UNUSED_ARG(depth);
10516 DEBUG_PARSE("clas");
10518 /* Assume we are going to generate an ANYOF node. */
10519 ret = reganode(pRExC_state, ANYOF, 0);
10523 ANYOF_FLAGS(ret) = 0;
10526 if (UCHARAT(RExC_parse) == '^') { /* Complement of range. */
10530 ANYOF_FLAGS(ret) |= ANYOF_INVERT;
10532 /* We have decided to not allow multi-char folds in inverted character
10533 * classes, due to the confusion that can happen, especially with
10534 * classes that are designed for a non-Unicode world: You have the
10535 * peculiar case that:
10536 "s s" =~ /^[^\xDF]+$/i => Y
10537 "ss" =~ /^[^\xDF]+$/i => N
10539 * See [perl #89750] */
10540 allow_full_fold = FALSE;
10544 RExC_size += ANYOF_SKIP;
10545 listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
10548 RExC_emit += ANYOF_SKIP;
10550 ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
10552 ANYOF_BITMAP_ZERO(ret);
10553 listsv = newSVpvs("# comment\n");
10554 initial_listsv_len = SvCUR(listsv);
10557 nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
10559 if (!SIZE_ONLY && POSIXCC(nextvalue))
10560 checkposixcc(pRExC_state);
10562 /* allow 1st char to be ] (allowing it to be - is dealt with later) */
10563 if (UCHARAT(RExC_parse) == ']')
10564 goto charclassloop;
10567 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
10571 namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
10574 rangebegin = RExC_parse;
10578 value = utf8n_to_uvchr((U8*)RExC_parse,
10579 RExC_end - RExC_parse,
10580 &numlen, UTF8_ALLOW_DEFAULT);
10581 RExC_parse += numlen;
10584 value = UCHARAT(RExC_parse++);
10586 nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
10587 if (value == '[' && POSIXCC(nextvalue))
10588 namedclass = regpposixcc(pRExC_state, value);
10589 else if (value == '\\') {
10591 value = utf8n_to_uvchr((U8*)RExC_parse,
10592 RExC_end - RExC_parse,
10593 &numlen, UTF8_ALLOW_DEFAULT);
10594 RExC_parse += numlen;
10597 value = UCHARAT(RExC_parse++);
10598 /* Some compilers cannot handle switching on 64-bit integer
10599 * values, therefore value cannot be an UV. Yes, this will
10600 * be a problem later if we want switch on Unicode.
10601 * A similar issue a little bit later when switching on
10602 * namedclass. --jhi */
10603 switch ((I32)value) {
10604 case 'w': namedclass = ANYOF_ALNUM; break;
10605 case 'W': namedclass = ANYOF_NALNUM; break;
10606 case 's': namedclass = ANYOF_SPACE; break;
10607 case 'S': namedclass = ANYOF_NSPACE; break;
10608 case 'd': namedclass = ANYOF_DIGIT; break;
10609 case 'D': namedclass = ANYOF_NDIGIT; break;
10610 case 'v': namedclass = ANYOF_VERTWS; break;
10611 case 'V': namedclass = ANYOF_NVERTWS; break;
10612 case 'h': namedclass = ANYOF_HORIZWS; break;
10613 case 'H': namedclass = ANYOF_NHORIZWS; break;
10614 case 'N': /* Handle \N{NAME} in class */
10616 /* We only pay attention to the first char of
10617 multichar strings being returned. I kinda wonder
10618 if this makes sense as it does change the behaviour
10619 from earlier versions, OTOH that behaviour was broken
10621 UV v; /* value is register so we cant & it /grrr */
10622 if (reg_namedseq(pRExC_state, &v, NULL, depth)) {
10632 if (RExC_parse >= RExC_end)
10633 vFAIL2("Empty \\%c{}", (U8)value);
10634 if (*RExC_parse == '{') {
10635 const U8 c = (U8)value;
10636 e = strchr(RExC_parse++, '}');
10638 vFAIL2("Missing right brace on \\%c{}", c);
10639 while (isSPACE(UCHARAT(RExC_parse)))
10641 if (e == RExC_parse)
10642 vFAIL2("Empty \\%c{}", c);
10643 n = e - RExC_parse;
10644 while (isSPACE(UCHARAT(RExC_parse + n - 1)))
10655 if (UCHARAT(RExC_parse) == '^') {
10658 value = value == 'p' ? 'P' : 'p'; /* toggle */
10659 while (isSPACE(UCHARAT(RExC_parse))) {
10664 /* Try to get the definition of the property into
10665 * <invlist>. If /i is in effect, the effective property
10666 * will have its name be <__NAME_i>. The design is
10667 * discussed in commit
10668 * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
10669 Newx(name, n + sizeof("_i__\n"), char);
10671 sprintf(name, "%s%.*s%s\n",
10672 (FOLD) ? "__" : "",
10678 /* Look up the property name, and get its swash and
10679 * inversion list, if the property is found */
10681 SvREFCNT_dec(swash);
10683 swash = _core_swash_init("utf8", name, &PL_sv_undef,
10686 TRUE, /* this routine will handle
10687 undefined properties */
10688 NULL, FALSE /* No inversion list */
10692 || ! SvTYPE(SvRV(swash)) == SVt_PVHV
10694 hv_fetchs(MUTABLE_HV(SvRV(swash)),
10696 || ! (invlist = *invlistsvp))
10699 SvREFCNT_dec(swash);
10703 /* Here didn't find it. It could be a user-defined
10704 * property that will be available at run-time. Add it
10705 * to the list to look up then */
10706 Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s\n",
10707 (value == 'p' ? '+' : '!'),
10709 has_user_defined_property = 1;
10711 /* We don't know yet, so have to assume that the
10712 * property could match something in the Latin1 range,
10713 * hence something that isn't utf8 */
10714 ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
10718 /* Here, did get the swash and its inversion list. If
10719 * the swash is from a user-defined property, then this
10720 * whole character class should be regarded as such */
10721 SV** user_defined_svp =
10722 hv_fetchs(MUTABLE_HV(SvRV(swash)),
10723 "USER_DEFINED", FALSE);
10724 if (user_defined_svp) {
10725 has_user_defined_property
10726 |= SvUV(*user_defined_svp);
10729 /* Invert if asking for the complement */
10730 if (value == 'P') {
10731 _invlist_union_complement_2nd(properties, invlist, &properties);
10733 /* The swash can't be used as-is, because we've
10734 * inverted things; delay removing it to here after
10735 * have copied its invlist above */
10736 SvREFCNT_dec(swash);
10740 _invlist_union(properties, invlist, &properties);
10745 RExC_parse = e + 1;
10746 namedclass = ANYOF_MAX; /* no official name, but it's named */
10748 /* \p means they want Unicode semantics */
10749 RExC_uni_semantics = 1;
10752 case 'n': value = '\n'; break;
10753 case 'r': value = '\r'; break;
10754 case 't': value = '\t'; break;
10755 case 'f': value = '\f'; break;
10756 case 'b': value = '\b'; break;
10757 case 'e': value = ASCII_TO_NATIVE('\033');break;
10758 case 'a': value = ASCII_TO_NATIVE('\007');break;
10760 RExC_parse--; /* function expects to be pointed at the 'o' */
10762 const char* error_msg;
10763 bool valid = grok_bslash_o(RExC_parse,
10768 RExC_parse += numlen;
10773 if (PL_encoding && value < 0x100) {
10774 goto recode_encoding;
10778 if (*RExC_parse == '{') {
10779 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
10780 | PERL_SCAN_DISALLOW_PREFIX;
10781 char * const e = strchr(RExC_parse++, '}');
10783 vFAIL("Missing right brace on \\x{}");
10785 numlen = e - RExC_parse;
10786 value = grok_hex(RExC_parse, &numlen, &flags, NULL);
10787 RExC_parse = e + 1;
10790 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
10792 value = grok_hex(RExC_parse, &numlen, &flags, NULL);
10793 RExC_parse += numlen;
10795 if (PL_encoding && value < 0x100)
10796 goto recode_encoding;
10799 value = grok_bslash_c(*RExC_parse++, UTF, SIZE_ONLY);
10801 case '0': case '1': case '2': case '3': case '4':
10802 case '5': case '6': case '7':
10804 /* Take 1-3 octal digits */
10805 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
10807 value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
10808 RExC_parse += numlen;
10809 if (PL_encoding && value < 0x100)
10810 goto recode_encoding;
10814 if (! RExC_override_recoding) {
10815 SV* enc = PL_encoding;
10816 value = reg_recode((const char)(U8)value, &enc);
10817 if (!enc && SIZE_ONLY)
10818 ckWARNreg(RExC_parse,
10819 "Invalid escape in the specified encoding");
10823 /* Allow \_ to not give an error */
10824 if (!SIZE_ONLY && isALNUM(value) && value != '_') {
10825 ckWARN2reg(RExC_parse,
10826 "Unrecognized escape \\%c in character class passed through",
10831 } /* end of \blah */
10834 literal_endpoint++;
10837 if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
10839 /* What matches in a locale is not known until runtime, so need to
10840 * (one time per class) allocate extra space to pass to regexec.
10841 * The space will contain a bit for each named class that is to be
10842 * matched against. This isn't needed for \p{} and pseudo-classes,
10843 * as they are not affected by locale, and hence are dealt with
10845 if (LOC && namedclass < ANYOF_MAX && ! need_class) {
10848 RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
10851 RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
10852 ANYOF_CLASS_ZERO(ret);
10854 ANYOF_FLAGS(ret) |= ANYOF_CLASS;
10857 /* a bad range like a-\d, a-[:digit:]. The '-' is taken as a
10858 * literal, as is the character that began the false range, i.e.
10859 * the 'a' in the examples */
10863 RExC_parse >= rangebegin ?
10864 RExC_parse - rangebegin : 0;
10865 ckWARN4reg(RExC_parse,
10866 "False [] range \"%*.*s\"",
10870 set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
10871 if (prevvalue < 256) {
10873 set_regclass_bit(pRExC_state, ret, (U8) prevvalue, &l1_fold_invlist, &unicode_alternate);
10876 nonbitmap = add_cp_to_invlist(nonbitmap, prevvalue);
10880 range = 0; /* this was not a true range */
10885 /* Possible truncation here but in some 64-bit environments
10886 * the compiler gets heartburn about switch on 64-bit values.
10887 * A similar issue a little earlier when switching on value.
10889 switch ((I32)namedclass) {
10890 int i; /* loop counter */
10892 case ANYOF_ALNUMC: /* C's alnum, in contrast to \w */
10893 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10894 PL_PosixAlnum, PL_L1PosixAlnum, "XPosixAlnum", listsv);
10896 case ANYOF_NALNUMC:
10897 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10898 PL_PosixAlnum, PL_L1PosixAlnum, "XPosixAlnum", listsv);
10901 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10902 PL_PosixAlpha, PL_L1PosixAlpha, "XPosixAlpha", listsv);
10905 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10906 PL_PosixAlpha, PL_L1PosixAlpha, "XPosixAlpha", listsv);
10910 ANYOF_CLASS_SET(ret, namedclass);
10913 _invlist_union(properties, PL_ASCII, &properties);
10918 ANYOF_CLASS_SET(ret, namedclass);
10921 _invlist_union_complement_2nd(properties,
10922 PL_ASCII, &properties);
10923 if (DEPENDS_SEMANTICS) {
10924 ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;
10929 DO_POSIX(ret, namedclass, properties,
10930 PL_PosixBlank, PL_XPosixBlank);
10933 DO_N_POSIX(ret, namedclass, properties,
10934 PL_PosixBlank, PL_XPosixBlank);
10937 DO_POSIX(ret, namedclass, properties,
10938 PL_PosixCntrl, PL_XPosixCntrl);
10941 DO_N_POSIX(ret, namedclass, properties,
10942 PL_PosixCntrl, PL_XPosixCntrl);
10945 /* Ignore the compiler warning for this macro, planned to
10946 * be eliminated later */
10947 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10948 PL_PosixDigit, PL_PosixDigit, "XPosixDigit", listsv);
10951 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10952 PL_PosixDigit, PL_PosixDigit, "XPosixDigit", listsv);
10955 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10956 PL_PosixGraph, PL_L1PosixGraph, "XPosixGraph", listsv);
10959 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10960 PL_PosixGraph, PL_L1PosixGraph, "XPosixGraph", listsv);
10962 case ANYOF_HORIZWS:
10963 /* NBSP matches this, and needs to be added unconditionally
10964 * to the bit map as it matches even under /d, unlike all
10965 * the rest of the Posix-like classes (\v doesn't have any
10966 * matches in the Latin1 range, so it is unaffected.) which
10967 * Otherwise, we use the nonbitmap, as /d doesn't make a
10968 * difference in what these match. It turns out that \h is
10969 * just a synonym for XPosixBlank */
10970 _invlist_union(nonbitmap, PL_XPosixBlank, &nonbitmap);
10971 stored += set_regclass_bit(pRExC_state, ret,
10972 UNI_TO_NATIVE(0xA0),
10974 &unicode_alternate);
10977 case ANYOF_NHORIZWS:
10978 _invlist_union_complement_2nd(nonbitmap,
10979 PL_XPosixBlank, &nonbitmap);
10980 for (i = 128; i < 256; i++) {
10984 stored += set_regclass_bit(pRExC_state, ret,
10987 &unicode_alternate);
10992 { /* These require special handling, as they differ under
10993 folding, matching Cased there (which in the ASCII range
10994 is the same as Alpha */
11000 if (FOLD && ! LOC) {
11001 ascii_source = PL_PosixAlpha;
11002 l1_source = PL_L1Cased;
11006 ascii_source = PL_PosixLower;
11007 l1_source = PL_L1PosixLower;
11008 Xname = "XPosixLower";
11010 if (namedclass == ANYOF_LOWER) {
11011 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11012 ascii_source, l1_source, Xname, listsv);
11015 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass,
11016 properties, ascii_source, l1_source, Xname, listsv);
11021 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11022 PL_PosixPrint, PL_L1PosixPrint, "XPosixPrint", listsv);
11025 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11026 PL_PosixPrint, PL_L1PosixPrint, "XPosixPrint", listsv);
11029 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11030 PL_PosixPunct, PL_L1PosixPunct, "XPosixPunct", listsv);
11033 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11034 PL_PosixPunct, PL_L1PosixPunct, "XPosixPunct", listsv);
11037 DO_POSIX(ret, namedclass, properties,
11038 PL_PosixSpace, PL_XPosixSpace);
11040 case ANYOF_NPSXSPC:
11041 DO_N_POSIX(ret, namedclass, properties,
11042 PL_PosixSpace, PL_XPosixSpace);
11045 DO_POSIX(ret, namedclass, properties,
11046 PL_PerlSpace, PL_XPerlSpace);
11049 DO_N_POSIX(ret, namedclass, properties,
11050 PL_PerlSpace, PL_XPerlSpace);
11052 case ANYOF_UPPER: /* Same as LOWER, above */
11059 if (FOLD && ! LOC) {
11060 ascii_source = PL_PosixAlpha;
11061 l1_source = PL_L1Cased;
11065 ascii_source = PL_PosixUpper;
11066 l1_source = PL_L1PosixUpper;
11067 Xname = "XPosixUpper";
11069 if (namedclass == ANYOF_UPPER) {
11070 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11071 ascii_source, l1_source, Xname, listsv);
11074 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass,
11075 properties, ascii_source, l1_source, Xname, listsv);
11079 case ANYOF_ALNUM: /* Really is 'Word' */
11080 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11081 PL_PosixWord, PL_L1PosixWord, "XPosixWord", listsv);
11084 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11085 PL_PosixWord, PL_L1PosixWord, "XPosixWord", listsv);
11088 /* For these, we use the nonbitmap, as /d doesn't make a
11089 * difference in what these match. There would be problems
11090 * if these characters had folds other than themselves, as
11091 * nonbitmap is subject to folding */
11092 _invlist_union(nonbitmap, PL_VertSpace, &nonbitmap);
11094 case ANYOF_NVERTWS:
11095 _invlist_union_complement_2nd(nonbitmap,
11096 PL_VertSpace, &nonbitmap);
11099 DO_POSIX(ret, namedclass, properties,
11100 PL_PosixXDigit, PL_XPosixXDigit);
11102 case ANYOF_NXDIGIT:
11103 DO_N_POSIX(ret, namedclass, properties,
11104 PL_PosixXDigit, PL_XPosixXDigit);
11107 /* this is to handle \p and \P */
11110 vFAIL("Invalid [::] class");
11116 } /* end of namedclass \blah */
11119 if (prevvalue > (IV)value) /* b-a */ {
11120 const int w = RExC_parse - rangebegin;
11121 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
11122 range = 0; /* not a valid range */
11126 prevvalue = value; /* save the beginning of the range */
11127 if (RExC_parse+1 < RExC_end
11128 && *RExC_parse == '-'
11129 && RExC_parse[1] != ']')
11133 /* a bad range like \w-, [:word:]- ? */
11134 if (namedclass > OOB_NAMEDCLASS) {
11135 if (ckWARN(WARN_REGEXP)) {
11137 RExC_parse >= rangebegin ?
11138 RExC_parse - rangebegin : 0;
11140 "False [] range \"%*.*s\"",
11145 set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
11147 range = 1; /* yeah, it's a range! */
11148 continue; /* but do it the next time */
11152 /* non-Latin1 code point implies unicode semantics. Must be set in
11153 * pass1 so is there for the whole of pass 2 */
11155 RExC_uni_semantics = 1;
11158 /* now is the next time */
11160 if (prevvalue < 256) {
11161 const IV ceilvalue = value < 256 ? value : 255;
11164 /* In EBCDIC [\x89-\x91] should include
11165 * the \x8e but [i-j] should not. */
11166 if (literal_endpoint == 2 &&
11167 ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
11168 (isUPPER(prevvalue) && isUPPER(ceilvalue))))
11170 if (isLOWER(prevvalue)) {
11171 for (i = prevvalue; i <= ceilvalue; i++)
11172 if (isLOWER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
11174 set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
11177 for (i = prevvalue; i <= ceilvalue; i++)
11178 if (isUPPER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
11180 set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
11186 for (i = prevvalue; i <= ceilvalue; i++) {
11187 stored += set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
11191 const UV prevnatvalue = NATIVE_TO_UNI(prevvalue);
11192 const UV natvalue = NATIVE_TO_UNI(value);
11193 nonbitmap = _add_range_to_invlist(nonbitmap, prevnatvalue, natvalue);
11196 literal_endpoint = 0;
11200 range = 0; /* this range (if it was one) is done now */
11207 /****** !SIZE_ONLY AFTER HERE *********/
11209 /* If folding and there are code points above 255, we calculate all
11210 * characters that could fold to or from the ones already on the list */
11211 if (FOLD && nonbitmap) {
11212 UV start, end; /* End points of code point ranges */
11214 SV* fold_intersection = NULL;
11216 /* This is a list of all the characters that participate in folds
11217 * (except marks, etc in multi-char folds */
11218 if (! PL_utf8_foldable) {
11219 SV* swash = swash_init("utf8", "Cased", &PL_sv_undef, 1, 0);
11220 PL_utf8_foldable = _swash_to_invlist(swash);
11221 SvREFCNT_dec(swash);
11224 /* This is a hash that for a particular fold gives all characters
11225 * that are involved in it */
11226 if (! PL_utf8_foldclosures) {
11228 /* If we were unable to find any folds, then we likely won't be
11229 * able to find the closures. So just create an empty list.
11230 * Folding will effectively be restricted to the non-Unicode rules
11231 * hard-coded into Perl. (This case happens legitimately during
11232 * compilation of Perl itself before the Unicode tables are
11234 if (invlist_len(PL_utf8_foldable) == 0) {
11235 PL_utf8_foldclosures = newHV();
11237 /* If the folds haven't been read in, call a fold function
11239 if (! PL_utf8_tofold) {
11240 U8 dummy[UTF8_MAXBYTES+1];
11243 /* This particular string is above \xff in both UTF-8 and
11245 to_utf8_fold((U8*) "\xC8\x80", dummy, &dummy_len);
11246 assert(PL_utf8_tofold); /* Verify that worked */
11248 PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
11252 /* Only the characters in this class that participate in folds need be
11253 * checked. Get the intersection of this class and all the possible
11254 * characters that are foldable. This can quickly narrow down a large
11256 _invlist_intersection(PL_utf8_foldable, nonbitmap, &fold_intersection);
11258 /* Now look at the foldable characters in this class individually */
11259 invlist_iterinit(fold_intersection);
11260 while (invlist_iternext(fold_intersection, &start, &end)) {
11263 /* Look at every character in the range */
11264 for (j = start; j <= end; j++) {
11267 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
11270 _to_uni_fold_flags(j, foldbuf, &foldlen, allow_full_fold);
11272 if (foldlen > (STRLEN)UNISKIP(f)) {
11274 /* Any multicharacter foldings (disallowed in lookbehind
11275 * patterns) require the following transform: [ABCDEF] ->
11276 * (?:[ABCabcDEFd]|pq|rst) where E folds into "pq" and F
11277 * folds into "rst", all other characters fold to single
11278 * characters. We save away these multicharacter foldings,
11279 * to be later saved as part of the additional "s" data. */
11280 if (! RExC_in_lookbehind) {
11282 U8* e = foldbuf + foldlen;
11284 /* If any of the folded characters of this are in the
11285 * Latin1 range, tell the regex engine that this can
11286 * match a non-utf8 target string. The only multi-byte
11287 * fold whose source is in the Latin1 range (U+00DF)
11288 * applies only when the target string is utf8, or
11289 * under unicode rules */
11290 if (j > 255 || AT_LEAST_UNI_SEMANTICS) {
11293 /* Can't mix ascii with non- under /aa */
11294 if (MORE_ASCII_RESTRICTED
11295 && (isASCII(*loc) != isASCII(j)))
11297 goto end_multi_fold;
11299 if (UTF8_IS_INVARIANT(*loc)
11300 || UTF8_IS_DOWNGRADEABLE_START(*loc))
11302 /* Can't mix above and below 256 under LOC
11305 goto end_multi_fold;
11308 |= ANYOF_NONBITMAP_NON_UTF8;
11311 loc += UTF8SKIP(loc);
11315 add_alternate(&unicode_alternate, foldbuf, foldlen);
11319 /* This is special-cased, as it is the only letter which
11320 * has both a multi-fold and single-fold in Latin1. All
11321 * the other chars that have single and multi-folds are
11322 * always in utf8, and the utf8 folding algorithm catches
11324 if (! LOC && j == LATIN_CAPITAL_LETTER_SHARP_S) {
11325 stored += set_regclass_bit(pRExC_state,
11327 LATIN_SMALL_LETTER_SHARP_S,
11328 &l1_fold_invlist, &unicode_alternate);
11332 /* Single character fold. Add everything in its fold
11333 * closure to the list that this node should match */
11336 /* The fold closures data structure is a hash with the keys
11337 * being every character that is folded to, like 'k', and
11338 * the values each an array of everything that folds to its
11339 * key. e.g. [ 'k', 'K', KELVIN_SIGN ] */
11340 if ((listp = hv_fetch(PL_utf8_foldclosures,
11341 (char *) foldbuf, foldlen, FALSE)))
11343 AV* list = (AV*) *listp;
11345 for (k = 0; k <= av_len(list); k++) {
11346 SV** c_p = av_fetch(list, k, FALSE);
11349 Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
11353 /* /aa doesn't allow folds between ASCII and non-;
11354 * /l doesn't allow them between above and below
11356 if ((MORE_ASCII_RESTRICTED
11357 && (isASCII(c) != isASCII(j)))
11358 || (LOC && ((c < 256) != (j < 256))))
11363 if (c < 256 && AT_LEAST_UNI_SEMANTICS) {
11364 stored += set_regclass_bit(pRExC_state,
11367 &l1_fold_invlist, &unicode_alternate);
11369 /* It may be that the code point is already in
11370 * this range or already in the bitmap, in
11371 * which case we need do nothing */
11372 else if ((c < start || c > end)
11374 || ! ANYOF_BITMAP_TEST(ret, c)))
11376 nonbitmap = add_cp_to_invlist(nonbitmap, c);
11383 SvREFCNT_dec(fold_intersection);
11386 /* Combine the two lists into one. */
11387 if (l1_fold_invlist) {
11389 _invlist_union(nonbitmap, l1_fold_invlist, &nonbitmap);
11390 SvREFCNT_dec(l1_fold_invlist);
11393 nonbitmap = l1_fold_invlist;
11397 /* And combine the result (if any) with any inversion list from properties.
11398 * The lists are kept separate up to now because we don't want to fold the
11402 _invlist_union(nonbitmap, properties, &nonbitmap);
11403 SvREFCNT_dec(properties);
11406 nonbitmap = properties;
11410 /* Here, <nonbitmap> contains all the code points we can determine at
11411 * compile time that we haven't put into the bitmap. Go through it, and
11412 * for things that belong in the bitmap, put them there, and delete from
11416 /* Above-ASCII code points in /d have to stay in <nonbitmap>, as they
11417 * possibly only should match when the target string is UTF-8 */
11418 UV max_cp_to_set = (DEPENDS_SEMANTICS) ? 127 : 255;
11420 /* This gets set if we actually need to modify things */
11421 bool change_invlist = FALSE;
11425 /* Start looking through <nonbitmap> */
11426 invlist_iterinit(nonbitmap);
11427 while (invlist_iternext(nonbitmap, &start, &end)) {
11431 /* Quit if are above what we should change */
11432 if (start > max_cp_to_set) {
11436 change_invlist = TRUE;
11438 /* Set all the bits in the range, up to the max that we are doing */
11439 high = (end < max_cp_to_set) ? end : max_cp_to_set;
11440 for (i = start; i <= (int) high; i++) {
11441 if (! ANYOF_BITMAP_TEST(ret, i)) {
11442 ANYOF_BITMAP_SET(ret, i);
11450 /* Done with loop; remove any code points that are in the bitmap from
11452 if (change_invlist) {
11453 _invlist_subtract(nonbitmap,
11454 (DEPENDS_SEMANTICS)
11460 /* If have completely emptied it, remove it completely */
11461 if (invlist_len(nonbitmap) == 0) {
11462 SvREFCNT_dec(nonbitmap);
11467 /* Here, we have calculated what code points should be in the character
11468 * class. <nonbitmap> does not overlap the bitmap except possibly in the
11469 * case of DEPENDS rules.
11471 * Now we can see about various optimizations. Fold calculation (which we
11472 * did above) needs to take place before inversion. Otherwise /[^k]/i
11473 * would invert to include K, which under /i would match k, which it
11476 /* Optimize inverted simple patterns (e.g. [^a-z]). Note that we haven't
11477 * set the FOLD flag yet, so this does optimize those. It doesn't
11478 * optimize locale. Doing so perhaps could be done as long as there is
11479 * nothing like \w in it; some thought also would have to be given to the
11480 * interaction with above 0x100 chars */
11481 if ((ANYOF_FLAGS(ret) & ANYOF_INVERT)
11483 && ! unicode_alternate
11484 /* In case of /d, there are some things that should match only when in
11485 * not in the bitmap, i.e., they require UTF8 to match. These are
11486 * listed in nonbitmap, but if ANYOF_NONBITMAP_NON_UTF8 is set in this
11487 * case, they don't require UTF8, so can invert here */
11489 || ! DEPENDS_SEMANTICS
11490 || (ANYOF_FLAGS(ret) & ANYOF_NONBITMAP_NON_UTF8))
11491 && SvCUR(listsv) == initial_listsv_len)
11495 for (i = 0; i < 256; ++i) {
11496 if (ANYOF_BITMAP_TEST(ret, i)) {
11497 ANYOF_BITMAP_CLEAR(ret, i);
11500 ANYOF_BITMAP_SET(ret, i);
11505 /* The inversion means that everything above 255 is matched */
11506 ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
11509 /* Here, also has things outside the bitmap that may overlap with
11510 * the bitmap. We have to sync them up, so that they get inverted
11511 * in both places. Earlier, we removed all overlaps except in the
11512 * case of /d rules, so no syncing is needed except for this case
11514 SV *remove_list = NULL;
11516 if (DEPENDS_SEMANTICS) {
11519 /* Set the bits that correspond to the ones that aren't in the
11520 * bitmap. Otherwise, when we invert, we'll miss these.
11521 * Earlier, we removed from the nonbitmap all code points
11522 * < 128, so there is no extra work here */
11523 invlist_iterinit(nonbitmap);
11524 while (invlist_iternext(nonbitmap, &start, &end)) {
11525 if (start > 255) { /* The bit map goes to 255 */
11531 for (i = start; i <= (int) end; ++i) {
11532 ANYOF_BITMAP_SET(ret, i);
11539 /* Now invert both the bitmap and the nonbitmap. Anything in the
11540 * bitmap has to also be removed from the non-bitmap, but again,
11541 * there should not be overlap unless is /d rules. */
11542 _invlist_invert(nonbitmap);
11544 /* Any swash can't be used as-is, because we've inverted things */
11546 SvREFCNT_dec(swash);
11550 for (i = 0; i < 256; ++i) {
11551 if (ANYOF_BITMAP_TEST(ret, i)) {
11552 ANYOF_BITMAP_CLEAR(ret, i);
11553 if (DEPENDS_SEMANTICS) {
11554 if (! remove_list) {
11555 remove_list = _new_invlist(2);
11557 remove_list = add_cp_to_invlist(remove_list, i);
11561 ANYOF_BITMAP_SET(ret, i);
11567 /* And do the removal */
11568 if (DEPENDS_SEMANTICS) {
11570 _invlist_subtract(nonbitmap, remove_list, &nonbitmap);
11571 SvREFCNT_dec(remove_list);
11575 /* There is no overlap for non-/d, so just delete anything
11577 _invlist_intersection(nonbitmap, PL_AboveLatin1, &nonbitmap);
11581 stored = 256 - stored;
11583 /* Clear the invert flag since have just done it here */
11584 ANYOF_FLAGS(ret) &= ~ANYOF_INVERT;
11587 /* Folding in the bitmap is taken care of above, but not for locale (for
11588 * which we have to wait to see what folding is in effect at runtime), and
11589 * for some things not in the bitmap (only the upper latin folds in this
11590 * case, as all other single-char folding has been set above). Set
11591 * run-time fold flag for these */
11593 || (DEPENDS_SEMANTICS
11595 && ! (ANYOF_FLAGS(ret) & ANYOF_NONBITMAP_NON_UTF8))
11596 || unicode_alternate))
11598 ANYOF_FLAGS(ret) |= ANYOF_LOC_NONBITMAP_FOLD;
11601 /* A single character class can be "optimized" into an EXACTish node.
11602 * Note that since we don't currently count how many characters there are
11603 * outside the bitmap, we are XXX missing optimization possibilities for
11604 * them. This optimization can't happen unless this is a truly single
11605 * character class, which means that it can't be an inversion into a
11606 * many-character class, and there must be no possibility of there being
11607 * things outside the bitmap. 'stored' (only) for locales doesn't include
11608 * \w, etc, so have to make a special test that they aren't present
11610 * Similarly A 2-character class of the very special form like [bB] can be
11611 * optimized into an EXACTFish node, but only for non-locales, and for
11612 * characters which only have the two folds; so things like 'fF' and 'Ii'
11613 * wouldn't work because they are part of the fold of 'LATIN SMALL LIGATURE
11616 && ! unicode_alternate
11617 && SvCUR(listsv) == initial_listsv_len
11618 && ! (ANYOF_FLAGS(ret) & (ANYOF_INVERT|ANYOF_UNICODE_ALL))
11619 && (((stored == 1 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
11620 || (! ANYOF_CLASS_TEST_ANY_SET(ret)))))
11621 || (stored == 2 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
11622 && (! _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value))
11623 /* If the latest code point has a fold whose
11624 * bit is set, it must be the only other one */
11625 && ((prevvalue = PL_fold_latin1[value]) != (IV)value)
11626 && ANYOF_BITMAP_TEST(ret, prevvalue)))))
11628 /* Note that the information needed to decide to do this optimization
11629 * is not currently available until the 2nd pass, and that the actually
11630 * used EXACTish node takes less space than the calculated ANYOF node,
11631 * and hence the amount of space calculated in the first pass is larger
11632 * than actually used, so this optimization doesn't gain us any space.
11633 * But an EXACT node is faster than an ANYOF node, and can be combined
11634 * with any adjacent EXACT nodes later by the optimizer for further
11635 * gains. The speed of executing an EXACTF is similar to an ANYOF
11636 * node, so the optimization advantage comes from the ability to join
11637 * it to adjacent EXACT nodes */
11639 const char * cur_parse= RExC_parse;
11641 RExC_emit = (regnode *)orig_emit;
11642 RExC_parse = (char *)orig_parse;
11646 /* A locale node with one point can be folded; all the other cases
11647 * with folding will have two points, since we calculate them above
11649 if (ANYOF_FLAGS(ret) & ANYOF_LOC_NONBITMAP_FOLD) {
11656 else { /* else 2 chars in the bit map: the folds of each other */
11658 /* Use the folded value, which for the cases where we get here,
11659 * is just the lower case of the current one (which may resolve to
11660 * itself, or to the other one */
11661 value = toLOWER_LATIN1(value);
11663 /* To join adjacent nodes, they must be the exact EXACTish type.
11664 * Try to use the most likely type, by using EXACTFA if possible,
11665 * then EXACTFU if the regex calls for it, or is required because
11666 * the character is non-ASCII. (If <value> is ASCII, its fold is
11667 * also ASCII for the cases where we get here.) */
11668 if (MORE_ASCII_RESTRICTED && isASCII(value)) {
11671 else if (AT_LEAST_UNI_SEMANTICS || !isASCII(value)) {
11674 else { /* Otherwise, more likely to be EXACTF type */
11679 ret = reg_node(pRExC_state, op);
11680 RExC_parse = (char *)cur_parse;
11681 if (UTF && ! NATIVE_IS_INVARIANT(value)) {
11682 *STRING(ret)= UTF8_EIGHT_BIT_HI((U8) value);
11683 *(STRING(ret) + 1)= UTF8_EIGHT_BIT_LO((U8) value);
11685 RExC_emit += STR_SZ(2);
11688 *STRING(ret)= (char)value;
11690 RExC_emit += STR_SZ(1);
11692 SvREFCNT_dec(listsv);
11696 /* If there is a swash and more than one element, we can't use the swash in
11697 * the optimization below. */
11698 if (swash && element_count > 1) {
11699 SvREFCNT_dec(swash);
11703 && SvCUR(listsv) == initial_listsv_len
11704 && ! unicode_alternate)
11706 ARG_SET(ret, ANYOF_NONBITMAP_EMPTY);
11707 SvREFCNT_dec(listsv);
11708 SvREFCNT_dec(unicode_alternate);
11711 /* av[0] stores the character class description in its textual form:
11712 * used later (regexec.c:Perl_regclass_swash()) to initialize the
11713 * appropriate swash, and is also useful for dumping the regnode.
11714 * av[1] if NULL, is a placeholder to later contain the swash computed
11715 * from av[0]. But if no further computation need be done, the
11716 * swash is stored there now.
11717 * av[2] stores the multicharacter foldings, used later in
11718 * regexec.c:S_reginclass().
11719 * av[3] stores the nonbitmap inversion list for use in addition or
11720 * instead of av[0]; not used if av[1] isn't NULL
11721 * av[4] is set if any component of the class is from a user-defined
11722 * property; not used if av[1] isn't NULL */
11723 AV * const av = newAV();
11726 av_store(av, 0, (SvCUR(listsv) == initial_listsv_len)
11730 av_store(av, 1, swash);
11731 SvREFCNT_dec(nonbitmap);
11734 av_store(av, 1, NULL);
11736 av_store(av, 3, nonbitmap);
11737 av_store(av, 4, newSVuv(has_user_defined_property));
11741 /* Store any computed multi-char folds only if we are allowing
11743 if (allow_full_fold) {
11744 av_store(av, 2, MUTABLE_SV(unicode_alternate));
11745 if (unicode_alternate) { /* This node is variable length */
11750 av_store(av, 2, NULL);
11752 rv = newRV_noinc(MUTABLE_SV(av));
11753 n = add_data(pRExC_state, 1, "s");
11754 RExC_rxi->data->data[n] = (void*)rv;
11761 /* reg_skipcomment()
11763 Absorbs an /x style # comments from the input stream.
11764 Returns true if there is more text remaining in the stream.
11765 Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment
11766 terminates the pattern without including a newline.
11768 Note its the callers responsibility to ensure that we are
11769 actually in /x mode
11774 S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state)
11778 PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
11780 while (RExC_parse < RExC_end)
11781 if (*RExC_parse++ == '\n') {
11786 /* we ran off the end of the pattern without ending
11787 the comment, so we have to add an \n when wrapping */
11788 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
11796 Advances the parse position, and optionally absorbs
11797 "whitespace" from the inputstream.
11799 Without /x "whitespace" means (?#...) style comments only,
11800 with /x this means (?#...) and # comments and whitespace proper.
11802 Returns the RExC_parse point from BEFORE the scan occurs.
11804 This is the /x friendly way of saying RExC_parse++.
11808 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
11810 char* const retval = RExC_parse++;
11812 PERL_ARGS_ASSERT_NEXTCHAR;
11815 if (RExC_end - RExC_parse >= 3
11816 && *RExC_parse == '('
11817 && RExC_parse[1] == '?'
11818 && RExC_parse[2] == '#')
11820 while (*RExC_parse != ')') {
11821 if (RExC_parse == RExC_end)
11822 FAIL("Sequence (?#... not terminated");
11828 if (RExC_flags & RXf_PMf_EXTENDED) {
11829 if (isSPACE(*RExC_parse)) {
11833 else if (*RExC_parse == '#') {
11834 if ( reg_skipcomment( pRExC_state ) )
11843 - reg_node - emit a node
11845 STATIC regnode * /* Location. */
11846 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
11849 register regnode *ptr;
11850 regnode * const ret = RExC_emit;
11851 GET_RE_DEBUG_FLAGS_DECL;
11853 PERL_ARGS_ASSERT_REG_NODE;
11856 SIZE_ALIGN(RExC_size);
11860 if (RExC_emit >= RExC_emit_bound)
11861 Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
11862 op, RExC_emit, RExC_emit_bound);
11864 NODE_ALIGN_FILL(ret);
11866 FILL_ADVANCE_NODE(ptr, op);
11867 REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (ptr) - 1);
11868 #ifdef RE_TRACK_PATTERN_OFFSETS
11869 if (RExC_offsets) { /* MJD */
11870 MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n",
11871 "reg_node", __LINE__,
11873 (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
11874 ? "Overwriting end of array!\n" : "OK",
11875 (UV)(RExC_emit - RExC_emit_start),
11876 (UV)(RExC_parse - RExC_start),
11877 (UV)RExC_offsets[0]));
11878 Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
11886 - reganode - emit a node with an argument
11888 STATIC regnode * /* Location. */
11889 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
11892 register regnode *ptr;
11893 regnode * const ret = RExC_emit;
11894 GET_RE_DEBUG_FLAGS_DECL;
11896 PERL_ARGS_ASSERT_REGANODE;
11899 SIZE_ALIGN(RExC_size);
11904 assert(2==regarglen[op]+1);
11906 Anything larger than this has to allocate the extra amount.
11907 If we changed this to be:
11909 RExC_size += (1 + regarglen[op]);
11911 then it wouldn't matter. Its not clear what side effect
11912 might come from that so its not done so far.
11917 if (RExC_emit >= RExC_emit_bound)
11918 Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
11919 op, RExC_emit, RExC_emit_bound);
11921 NODE_ALIGN_FILL(ret);
11923 FILL_ADVANCE_NODE_ARG(ptr, op, arg);
11924 REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (ptr) - 2);
11925 #ifdef RE_TRACK_PATTERN_OFFSETS
11926 if (RExC_offsets) { /* MJD */
11927 MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
11931 (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ?
11932 "Overwriting end of array!\n" : "OK",
11933 (UV)(RExC_emit - RExC_emit_start),
11934 (UV)(RExC_parse - RExC_start),
11935 (UV)RExC_offsets[0]));
11936 Set_Cur_Node_Offset;
11944 - reguni - emit (if appropriate) a Unicode character
11947 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
11951 PERL_ARGS_ASSERT_REGUNI;
11953 return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
11957 - reginsert - insert an operator in front of already-emitted operand
11959 * Means relocating the operand.
11962 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
11965 register regnode *src;
11966 register regnode *dst;
11967 register regnode *place;
11968 const int offset = regarglen[(U8)op];
11969 const int size = NODE_STEP_REGNODE + offset;
11970 GET_RE_DEBUG_FLAGS_DECL;
11972 PERL_ARGS_ASSERT_REGINSERT;
11973 PERL_UNUSED_ARG(depth);
11974 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
11975 DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
11984 if (RExC_open_parens) {
11986 /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
11987 for ( paren=0 ; paren < RExC_npar ; paren++ ) {
11988 if ( RExC_open_parens[paren] >= opnd ) {
11989 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
11990 RExC_open_parens[paren] += size;
11992 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
11994 if ( RExC_close_parens[paren] >= opnd ) {
11995 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
11996 RExC_close_parens[paren] += size;
11998 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
12003 while (src > opnd) {
12004 StructCopy(--src, --dst, regnode);
12005 #ifdef RE_TRACK_PATTERN_OFFSETS
12006 if (RExC_offsets) { /* MJD 20010112 */
12007 MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
12011 (UV)(dst - RExC_emit_start) > RExC_offsets[0]
12012 ? "Overwriting end of array!\n" : "OK",
12013 (UV)(src - RExC_emit_start),
12014 (UV)(dst - RExC_emit_start),
12015 (UV)RExC_offsets[0]));
12016 Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
12017 Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
12023 place = opnd; /* Op node, where operand used to be. */
12024 #ifdef RE_TRACK_PATTERN_OFFSETS
12025 if (RExC_offsets) { /* MJD */
12026 MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
12030 (UV)(place - RExC_emit_start) > RExC_offsets[0]
12031 ? "Overwriting end of array!\n" : "OK",
12032 (UV)(place - RExC_emit_start),
12033 (UV)(RExC_parse - RExC_start),
12034 (UV)RExC_offsets[0]));
12035 Set_Node_Offset(place, RExC_parse);
12036 Set_Node_Length(place, 1);
12039 src = NEXTOPER(place);
12040 FILL_ADVANCE_NODE(place, op);
12041 REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (place) - 1);
12042 Zero(src, offset, regnode);
12046 - regtail - set the next-pointer at the end of a node chain of p to val.
12047 - SEE ALSO: regtail_study
12049 /* TODO: All three parms should be const */
12051 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
12054 register regnode *scan;
12055 GET_RE_DEBUG_FLAGS_DECL;
12057 PERL_ARGS_ASSERT_REGTAIL;
12059 PERL_UNUSED_ARG(depth);
12065 /* Find last node. */
12068 regnode * const temp = regnext(scan);
12070 SV * const mysv=sv_newmortal();
12071 DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
12072 regprop(RExC_rx, mysv, scan);
12073 PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
12074 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
12075 (temp == NULL ? "->" : ""),
12076 (temp == NULL ? PL_reg_name[OP(val)] : "")
12084 if (reg_off_by_arg[OP(scan)]) {
12085 ARG_SET(scan, val - scan);
12088 NEXT_OFF(scan) = val - scan;
12094 - regtail_study - set the next-pointer at the end of a node chain of p to val.
12095 - Look for optimizable sequences at the same time.
12096 - currently only looks for EXACT chains.
12098 This is experimental code. The idea is to use this routine to perform
12099 in place optimizations on branches and groups as they are constructed,
12100 with the long term intention of removing optimization from study_chunk so
12101 that it is purely analytical.
12103 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
12104 to control which is which.
12107 /* TODO: All four parms should be const */
12110 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
12113 register regnode *scan;
12115 #ifdef EXPERIMENTAL_INPLACESCAN
12118 GET_RE_DEBUG_FLAGS_DECL;
12120 PERL_ARGS_ASSERT_REGTAIL_STUDY;
12126 /* Find last node. */
12130 regnode * const temp = regnext(scan);
12131 #ifdef EXPERIMENTAL_INPLACESCAN
12132 if (PL_regkind[OP(scan)] == EXACT) {
12133 bool has_exactf_sharp_s; /* Unexamined in this routine */
12134 if (join_exact(pRExC_state,scan,&min, &has_exactf_sharp_s, 1,val,depth+1))
12139 switch (OP(scan)) {
12145 case EXACTFU_TRICKYFOLD:
12147 if( exact == PSEUDO )
12149 else if ( exact != OP(scan) )
12158 SV * const mysv=sv_newmortal();
12159 DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
12160 regprop(RExC_rx, mysv, scan);
12161 PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
12162 SvPV_nolen_const(mysv),
12163 REG_NODE_NUM(scan),
12164 PL_reg_name[exact]);
12171 SV * const mysv_val=sv_newmortal();
12172 DEBUG_PARSE_MSG("");
12173 regprop(RExC_rx, mysv_val, val);
12174 PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
12175 SvPV_nolen_const(mysv_val),
12176 (IV)REG_NODE_NUM(val),
12180 if (reg_off_by_arg[OP(scan)]) {
12181 ARG_SET(scan, val - scan);
12184 NEXT_OFF(scan) = val - scan;
12192 - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
12196 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
12202 for (bit=0; bit<32; bit++) {
12203 if (flags & (1<<bit)) {
12204 if ((1<<bit) & RXf_PMf_CHARSET) { /* Output separately, below */
12207 if (!set++ && lead)
12208 PerlIO_printf(Perl_debug_log, "%s",lead);
12209 PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
12212 if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
12213 if (!set++ && lead) {
12214 PerlIO_printf(Perl_debug_log, "%s",lead);
12217 case REGEX_UNICODE_CHARSET:
12218 PerlIO_printf(Perl_debug_log, "UNICODE");
12220 case REGEX_LOCALE_CHARSET:
12221 PerlIO_printf(Perl_debug_log, "LOCALE");
12223 case REGEX_ASCII_RESTRICTED_CHARSET:
12224 PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
12226 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
12227 PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
12230 PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
12236 PerlIO_printf(Perl_debug_log, "\n");
12238 PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
12244 Perl_regdump(pTHX_ const regexp *r)
12248 SV * const sv = sv_newmortal();
12249 SV *dsv= sv_newmortal();
12250 RXi_GET_DECL(r,ri);
12251 GET_RE_DEBUG_FLAGS_DECL;
12253 PERL_ARGS_ASSERT_REGDUMP;
12255 (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
12257 /* Header fields of interest. */
12258 if (r->anchored_substr) {
12259 RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr),
12260 RE_SV_DUMPLEN(r->anchored_substr), 30);
12261 PerlIO_printf(Perl_debug_log,
12262 "anchored %s%s at %"IVdf" ",
12263 s, RE_SV_TAIL(r->anchored_substr),
12264 (IV)r->anchored_offset);
12265 } else if (r->anchored_utf8) {
12266 RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8),
12267 RE_SV_DUMPLEN(r->anchored_utf8), 30);
12268 PerlIO_printf(Perl_debug_log,
12269 "anchored utf8 %s%s at %"IVdf" ",
12270 s, RE_SV_TAIL(r->anchored_utf8),
12271 (IV)r->anchored_offset);
12273 if (r->float_substr) {
12274 RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr),
12275 RE_SV_DUMPLEN(r->float_substr), 30);
12276 PerlIO_printf(Perl_debug_log,
12277 "floating %s%s at %"IVdf"..%"UVuf" ",
12278 s, RE_SV_TAIL(r->float_substr),
12279 (IV)r->float_min_offset, (UV)r->float_max_offset);
12280 } else if (r->float_utf8) {
12281 RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8),
12282 RE_SV_DUMPLEN(r->float_utf8), 30);
12283 PerlIO_printf(Perl_debug_log,
12284 "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
12285 s, RE_SV_TAIL(r->float_utf8),
12286 (IV)r->float_min_offset, (UV)r->float_max_offset);
12288 if (r->check_substr || r->check_utf8)
12289 PerlIO_printf(Perl_debug_log,
12291 (r->check_substr == r->float_substr
12292 && r->check_utf8 == r->float_utf8
12293 ? "(checking floating" : "(checking anchored"));
12294 if (r->extflags & RXf_NOSCAN)
12295 PerlIO_printf(Perl_debug_log, " noscan");
12296 if (r->extflags & RXf_CHECK_ALL)
12297 PerlIO_printf(Perl_debug_log, " isall");
12298 if (r->check_substr || r->check_utf8)
12299 PerlIO_printf(Perl_debug_log, ") ");
12301 if (ri->regstclass) {
12302 regprop(r, sv, ri->regstclass);
12303 PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
12305 if (r->extflags & RXf_ANCH) {
12306 PerlIO_printf(Perl_debug_log, "anchored");
12307 if (r->extflags & RXf_ANCH_BOL)
12308 PerlIO_printf(Perl_debug_log, "(BOL)");
12309 if (r->extflags & RXf_ANCH_MBOL)
12310 PerlIO_printf(Perl_debug_log, "(MBOL)");
12311 if (r->extflags & RXf_ANCH_SBOL)
12312 PerlIO_printf(Perl_debug_log, "(SBOL)");
12313 if (r->extflags & RXf_ANCH_GPOS)
12314 PerlIO_printf(Perl_debug_log, "(GPOS)");
12315 PerlIO_putc(Perl_debug_log, ' ');
12317 if (r->extflags & RXf_GPOS_SEEN)
12318 PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
12319 if (r->intflags & PREGf_SKIP)
12320 PerlIO_printf(Perl_debug_log, "plus ");
12321 if (r->intflags & PREGf_IMPLICIT)
12322 PerlIO_printf(Perl_debug_log, "implicit ");
12323 PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
12324 if (r->extflags & RXf_EVAL_SEEN)
12325 PerlIO_printf(Perl_debug_log, "with eval ");
12326 PerlIO_printf(Perl_debug_log, "\n");
12327 DEBUG_FLAGS_r(regdump_extflags("r->extflags: ",r->extflags));
12329 PERL_ARGS_ASSERT_REGDUMP;
12330 PERL_UNUSED_CONTEXT;
12331 PERL_UNUSED_ARG(r);
12332 #endif /* DEBUGGING */
12336 - regprop - printable representation of opcode
12338 #define EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags) \
12341 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]); \
12342 if (flags & ANYOF_INVERT) \
12343 /*make sure the invert info is in each */ \
12344 sv_catpvs(sv, "^"); \
12350 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
12355 RXi_GET_DECL(prog,progi);
12356 GET_RE_DEBUG_FLAGS_DECL;
12358 PERL_ARGS_ASSERT_REGPROP;
12362 if (OP(o) > REGNODE_MAX) /* regnode.type is unsigned */
12363 /* It would be nice to FAIL() here, but this may be called from
12364 regexec.c, and it would be hard to supply pRExC_state. */
12365 Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
12366 sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
12368 k = PL_regkind[OP(o)];
12371 sv_catpvs(sv, " ");
12372 /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
12373 * is a crude hack but it may be the best for now since
12374 * we have no flag "this EXACTish node was UTF-8"
12376 pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
12377 PERL_PV_ESCAPE_UNI_DETECT |
12378 PERL_PV_ESCAPE_NONASCII |
12379 PERL_PV_PRETTY_ELLIPSES |
12380 PERL_PV_PRETTY_LTGT |
12381 PERL_PV_PRETTY_NOCLEAR
12383 } else if (k == TRIE) {
12384 /* print the details of the trie in dumpuntil instead, as
12385 * progi->data isn't available here */
12386 const char op = OP(o);
12387 const U32 n = ARG(o);
12388 const reg_ac_data * const ac = IS_TRIE_AC(op) ?
12389 (reg_ac_data *)progi->data->data[n] :
12391 const reg_trie_data * const trie
12392 = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
12394 Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
12395 DEBUG_TRIE_COMPILE_r(
12396 Perl_sv_catpvf(aTHX_ sv,
12397 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
12398 (UV)trie->startstate,
12399 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
12400 (UV)trie->wordcount,
12403 (UV)TRIE_CHARCOUNT(trie),
12404 (UV)trie->uniquecharcount
12407 if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
12409 int rangestart = -1;
12410 U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
12411 sv_catpvs(sv, "[");
12412 for (i = 0; i <= 256; i++) {
12413 if (i < 256 && BITMAP_TEST(bitmap,i)) {
12414 if (rangestart == -1)
12416 } else if (rangestart != -1) {
12417 if (i <= rangestart + 3)
12418 for (; rangestart < i; rangestart++)
12419 put_byte(sv, rangestart);
12421 put_byte(sv, rangestart);
12422 sv_catpvs(sv, "-");
12423 put_byte(sv, i - 1);
12428 sv_catpvs(sv, "]");
12431 } else if (k == CURLY) {
12432 if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
12433 Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
12434 Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
12436 else if (k == WHILEM && o->flags) /* Ordinal/of */
12437 Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
12438 else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
12439 Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */
12440 if ( RXp_PAREN_NAMES(prog) ) {
12441 if ( k != REF || (OP(o) < NREF)) {
12442 AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
12443 SV **name= av_fetch(list, ARG(o), 0 );
12445 Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
12448 AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]);
12449 SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
12450 I32 *nums=(I32*)SvPVX(sv_dat);
12451 SV **name= av_fetch(list, nums[0], 0 );
12454 for ( n=0; n<SvIVX(sv_dat); n++ ) {
12455 Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
12456 (n ? "," : ""), (IV)nums[n]);
12458 Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
12462 } else if (k == GOSUB)
12463 Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
12464 else if (k == VERB) {
12466 Perl_sv_catpvf(aTHX_ sv, ":%"SVf,
12467 SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
12468 } else if (k == LOGICAL)
12469 Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */
12470 else if (k == ANYOF) {
12471 int i, rangestart = -1;
12472 const U8 flags = ANYOF_FLAGS(o);
12475 /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
12476 static const char * const anyofs[] = {
12509 if (flags & ANYOF_LOCALE)
12510 sv_catpvs(sv, "{loc}");
12511 if (flags & ANYOF_LOC_NONBITMAP_FOLD)
12512 sv_catpvs(sv, "{i}");
12513 Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
12514 if (flags & ANYOF_INVERT)
12515 sv_catpvs(sv, "^");
12517 /* output what the standard cp 0-255 bitmap matches */
12518 for (i = 0; i <= 256; i++) {
12519 if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
12520 if (rangestart == -1)
12522 } else if (rangestart != -1) {
12523 if (i <= rangestart + 3)
12524 for (; rangestart < i; rangestart++)
12525 put_byte(sv, rangestart);
12527 put_byte(sv, rangestart);
12528 sv_catpvs(sv, "-");
12529 put_byte(sv, i - 1);
12536 EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
12537 /* output any special charclass tests (used entirely under use locale) */
12538 if (ANYOF_CLASS_TEST_ANY_SET(o))
12539 for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
12540 if (ANYOF_CLASS_TEST(o,i)) {
12541 sv_catpv(sv, anyofs[i]);
12545 EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
12547 if (flags & ANYOF_NON_UTF8_LATIN1_ALL) {
12548 sv_catpvs(sv, "{non-utf8-latin1-all}");
12551 /* output information about the unicode matching */
12552 if (flags & ANYOF_UNICODE_ALL)
12553 sv_catpvs(sv, "{unicode_all}");
12554 else if (ANYOF_NONBITMAP(o))
12555 sv_catpvs(sv, "{unicode}");
12556 if (flags & ANYOF_NONBITMAP_NON_UTF8)
12557 sv_catpvs(sv, "{outside bitmap}");
12559 if (ANYOF_NONBITMAP(o)) {
12560 SV *lv; /* Set if there is something outside the bit map */
12561 SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
12562 bool byte_output = FALSE; /* If something in the bitmap has been
12565 if (lv && lv != &PL_sv_undef) {
12567 U8 s[UTF8_MAXBYTES_CASE+1];
12569 for (i = 0; i <= 256; i++) { /* Look at chars in bitmap */
12570 uvchr_to_utf8(s, i);
12573 && ! ANYOF_BITMAP_TEST(o, i) /* Don't duplicate
12577 && swash_fetch(sw, s, TRUE))
12579 if (rangestart == -1)
12581 } else if (rangestart != -1) {
12582 byte_output = TRUE;
12583 if (i <= rangestart + 3)
12584 for (; rangestart < i; rangestart++) {
12585 put_byte(sv, rangestart);
12588 put_byte(sv, rangestart);
12589 sv_catpvs(sv, "-");
12598 char *s = savesvpv(lv);
12599 char * const origs = s;
12601 while (*s && *s != '\n')
12605 const char * const t = ++s;
12608 sv_catpvs(sv, " ");
12614 /* Truncate very long output */
12615 if (s - origs > 256) {
12616 Perl_sv_catpvf(aTHX_ sv,
12618 (int) (s - origs - 1),
12624 else if (*s == '\t') {
12643 Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
12645 else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
12646 Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
12648 PERL_UNUSED_CONTEXT;
12649 PERL_UNUSED_ARG(sv);
12650 PERL_UNUSED_ARG(o);
12651 PERL_UNUSED_ARG(prog);
12652 #endif /* DEBUGGING */
12656 Perl_re_intuit_string(pTHX_ REGEXP * const r)
12657 { /* Assume that RE_INTUIT is set */
12659 struct regexp *const prog = (struct regexp *)SvANY(r);
12660 GET_RE_DEBUG_FLAGS_DECL;
12662 PERL_ARGS_ASSERT_RE_INTUIT_STRING;
12663 PERL_UNUSED_CONTEXT;
12667 const char * const s = SvPV_nolen_const(prog->check_substr
12668 ? prog->check_substr : prog->check_utf8);
12670 if (!PL_colorset) reginitcolors();
12671 PerlIO_printf(Perl_debug_log,
12672 "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
12674 prog->check_substr ? "" : "utf8 ",
12675 PL_colors[5],PL_colors[0],
12678 (strlen(s) > 60 ? "..." : ""));
12681 return prog->check_substr ? prog->check_substr : prog->check_utf8;
12687 handles refcounting and freeing the perl core regexp structure. When
12688 it is necessary to actually free the structure the first thing it
12689 does is call the 'free' method of the regexp_engine associated to
12690 the regexp, allowing the handling of the void *pprivate; member
12691 first. (This routine is not overridable by extensions, which is why
12692 the extensions free is called first.)
12694 See regdupe and regdupe_internal if you change anything here.
12696 #ifndef PERL_IN_XSUB_RE
12698 Perl_pregfree(pTHX_ REGEXP *r)
12704 Perl_pregfree2(pTHX_ REGEXP *rx)
12707 struct regexp *const r = (struct regexp *)SvANY(rx);
12708 GET_RE_DEBUG_FLAGS_DECL;
12710 PERL_ARGS_ASSERT_PREGFREE2;
12712 if (r->mother_re) {
12713 ReREFCNT_dec(r->mother_re);
12715 CALLREGFREE_PVT(rx); /* free the private data */
12716 SvREFCNT_dec(RXp_PAREN_NAMES(r));
12719 SvREFCNT_dec(r->anchored_substr);
12720 SvREFCNT_dec(r->anchored_utf8);
12721 SvREFCNT_dec(r->float_substr);
12722 SvREFCNT_dec(r->float_utf8);
12723 Safefree(r->substrs);
12725 RX_MATCH_COPY_FREE(rx);
12726 #ifdef PERL_OLD_COPY_ON_WRITE
12727 SvREFCNT_dec(r->saved_copy);
12734 This is a hacky workaround to the structural issue of match results
12735 being stored in the regexp structure which is in turn stored in
12736 PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
12737 could be PL_curpm in multiple contexts, and could require multiple
12738 result sets being associated with the pattern simultaneously, such
12739 as when doing a recursive match with (??{$qr})
12741 The solution is to make a lightweight copy of the regexp structure
12742 when a qr// is returned from the code executed by (??{$qr}) this
12743 lightweight copy doesn't actually own any of its data except for
12744 the starp/end and the actual regexp structure itself.
12750 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
12752 struct regexp *ret;
12753 struct regexp *const r = (struct regexp *)SvANY(rx);
12754 register const I32 npar = r->nparens+1;
12756 PERL_ARGS_ASSERT_REG_TEMP_COPY;
12759 ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
12760 ret = (struct regexp *)SvANY(ret_x);
12762 (void)ReREFCNT_inc(rx);
12763 /* We can take advantage of the existing "copied buffer" mechanism in SVs
12764 by pointing directly at the buffer, but flagging that the allocated
12765 space in the copy is zero. As we've just done a struct copy, it's now
12766 a case of zero-ing that, rather than copying the current length. */
12767 SvPV_set(ret_x, RX_WRAPPED(rx));
12768 SvFLAGS(ret_x) |= SvFLAGS(rx) & (SVf_POK|SVp_POK|SVf_UTF8);
12769 memcpy(&(ret->xpv_cur), &(r->xpv_cur),
12770 sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
12771 SvLEN_set(ret_x, 0);
12772 SvSTASH_set(ret_x, NULL);
12773 SvMAGIC_set(ret_x, NULL);
12774 Newx(ret->offs, npar, regexp_paren_pair);
12775 Copy(r->offs, ret->offs, npar, regexp_paren_pair);
12777 Newx(ret->substrs, 1, struct reg_substr_data);
12778 StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
12780 SvREFCNT_inc_void(ret->anchored_substr);
12781 SvREFCNT_inc_void(ret->anchored_utf8);
12782 SvREFCNT_inc_void(ret->float_substr);
12783 SvREFCNT_inc_void(ret->float_utf8);
12785 /* check_substr and check_utf8, if non-NULL, point to either their
12786 anchored or float namesakes, and don't hold a second reference. */
12788 RX_MATCH_COPIED_off(ret_x);
12789 #ifdef PERL_OLD_COPY_ON_WRITE
12790 ret->saved_copy = NULL;
12792 ret->mother_re = rx;
12798 /* regfree_internal()
12800 Free the private data in a regexp. This is overloadable by
12801 extensions. Perl takes care of the regexp structure in pregfree(),
12802 this covers the *pprivate pointer which technically perl doesn't
12803 know about, however of course we have to handle the
12804 regexp_internal structure when no extension is in use.
12806 Note this is called before freeing anything in the regexp
12811 Perl_regfree_internal(pTHX_ REGEXP * const rx)
12814 struct regexp *const r = (struct regexp *)SvANY(rx);
12815 RXi_GET_DECL(r,ri);
12816 GET_RE_DEBUG_FLAGS_DECL;
12818 PERL_ARGS_ASSERT_REGFREE_INTERNAL;
12824 SV *dsv= sv_newmortal();
12825 RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
12826 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
12827 PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n",
12828 PL_colors[4],PL_colors[5],s);
12831 #ifdef RE_TRACK_PATTERN_OFFSETS
12833 Safefree(ri->u.offsets); /* 20010421 MJD */
12836 int n = ri->data->count;
12837 PAD* new_comppad = NULL;
12842 /* If you add a ->what type here, update the comment in regcomp.h */
12843 switch (ri->data->what[n]) {
12848 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
12851 Safefree(ri->data->data[n]);
12854 new_comppad = MUTABLE_AV(ri->data->data[n]);
12857 if (new_comppad == NULL)
12858 Perl_croak(aTHX_ "panic: pregfree comppad");
12859 PAD_SAVE_LOCAL(old_comppad,
12860 /* Watch out for global destruction's random ordering. */
12861 (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
12864 refcnt = OpREFCNT_dec((OP_4tree*)ri->data->data[n]);
12867 op_free((OP_4tree*)ri->data->data[n]);
12869 PAD_RESTORE_LOCAL(old_comppad);
12870 SvREFCNT_dec(MUTABLE_SV(new_comppad));
12871 new_comppad = NULL;
12876 { /* Aho Corasick add-on structure for a trie node.
12877 Used in stclass optimization only */
12879 reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
12881 refcount = --aho->refcount;
12884 PerlMemShared_free(aho->states);
12885 PerlMemShared_free(aho->fail);
12886 /* do this last!!!! */
12887 PerlMemShared_free(ri->data->data[n]);
12888 PerlMemShared_free(ri->regstclass);
12894 /* trie structure. */
12896 reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
12898 refcount = --trie->refcount;
12901 PerlMemShared_free(trie->charmap);
12902 PerlMemShared_free(trie->states);
12903 PerlMemShared_free(trie->trans);
12905 PerlMemShared_free(trie->bitmap);
12907 PerlMemShared_free(trie->jump);
12908 PerlMemShared_free(trie->wordinfo);
12909 /* do this last!!!! */
12910 PerlMemShared_free(ri->data->data[n]);
12915 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
12918 Safefree(ri->data->what);
12919 Safefree(ri->data);
12925 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
12926 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
12927 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
12930 re_dup - duplicate a regexp.
12932 This routine is expected to clone a given regexp structure. It is only
12933 compiled under USE_ITHREADS.
12935 After all of the core data stored in struct regexp is duplicated
12936 the regexp_engine.dupe method is used to copy any private data
12937 stored in the *pprivate pointer. This allows extensions to handle
12938 any duplication it needs to do.
12940 See pregfree() and regfree_internal() if you change anything here.
12942 #if defined(USE_ITHREADS)
12943 #ifndef PERL_IN_XSUB_RE
12945 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
12949 const struct regexp *r = (const struct regexp *)SvANY(sstr);
12950 struct regexp *ret = (struct regexp *)SvANY(dstr);
12952 PERL_ARGS_ASSERT_RE_DUP_GUTS;
12954 npar = r->nparens+1;
12955 Newx(ret->offs, npar, regexp_paren_pair);
12956 Copy(r->offs, ret->offs, npar, regexp_paren_pair);
12958 /* no need to copy these */
12959 Newx(ret->swap, npar, regexp_paren_pair);
12962 if (ret->substrs) {
12963 /* Do it this way to avoid reading from *r after the StructCopy().
12964 That way, if any of the sv_dup_inc()s dislodge *r from the L1
12965 cache, it doesn't matter. */
12966 const bool anchored = r->check_substr
12967 ? r->check_substr == r->anchored_substr
12968 : r->check_utf8 == r->anchored_utf8;
12969 Newx(ret->substrs, 1, struct reg_substr_data);
12970 StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
12972 ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
12973 ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
12974 ret->float_substr = sv_dup_inc(ret->float_substr, param);
12975 ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
12977 /* check_substr and check_utf8, if non-NULL, point to either their
12978 anchored or float namesakes, and don't hold a second reference. */
12980 if (ret->check_substr) {
12982 assert(r->check_utf8 == r->anchored_utf8);
12983 ret->check_substr = ret->anchored_substr;
12984 ret->check_utf8 = ret->anchored_utf8;
12986 assert(r->check_substr == r->float_substr);
12987 assert(r->check_utf8 == r->float_utf8);
12988 ret->check_substr = ret->float_substr;
12989 ret->check_utf8 = ret->float_utf8;
12991 } else if (ret->check_utf8) {
12993 ret->check_utf8 = ret->anchored_utf8;
12995 ret->check_utf8 = ret->float_utf8;
13000 RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
13003 RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
13005 if (RX_MATCH_COPIED(dstr))
13006 ret->subbeg = SAVEPVN(ret->subbeg, ret->sublen);
13008 ret->subbeg = NULL;
13009 #ifdef PERL_OLD_COPY_ON_WRITE
13010 ret->saved_copy = NULL;
13013 if (ret->mother_re) {
13014 if (SvPVX_const(dstr) == SvPVX_const(ret->mother_re)) {
13015 /* Our storage points directly to our mother regexp, but that's
13016 1: a buffer in a different thread
13017 2: something we no longer hold a reference on
13018 so we need to copy it locally. */
13019 /* Note we need to use SvCUR(), rather than
13020 SvLEN(), on our mother_re, because it, in
13021 turn, may well be pointing to its own mother_re. */
13022 SvPV_set(dstr, SAVEPVN(SvPVX_const(ret->mother_re),
13023 SvCUR(ret->mother_re)+1));
13024 SvLEN_set(dstr, SvCUR(ret->mother_re)+1);
13026 ret->mother_re = NULL;
13030 #endif /* PERL_IN_XSUB_RE */
13035 This is the internal complement to regdupe() which is used to copy
13036 the structure pointed to by the *pprivate pointer in the regexp.
13037 This is the core version of the extension overridable cloning hook.
13038 The regexp structure being duplicated will be copied by perl prior
13039 to this and will be provided as the regexp *r argument, however
13040 with the /old/ structures pprivate pointer value. Thus this routine
13041 may override any copying normally done by perl.
13043 It returns a pointer to the new regexp_internal structure.
13047 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
13050 struct regexp *const r = (struct regexp *)SvANY(rx);
13051 regexp_internal *reti;
13053 RXi_GET_DECL(r,ri);
13055 PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
13059 Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);
13060 Copy(ri->program, reti->program, len+1, regnode);
13063 reti->regstclass = NULL;
13066 struct reg_data *d;
13067 const int count = ri->data->count;
13070 Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
13071 char, struct reg_data);
13072 Newx(d->what, count, U8);
13075 for (i = 0; i < count; i++) {
13076 d->what[i] = ri->data->what[i];
13077 switch (d->what[i]) {
13078 /* legal options are one of: sSfpontTua
13079 see also regcomp.h and pregfree() */
13080 case 'a': /* actually an AV, but the dup function is identical. */
13083 case 'p': /* actually an AV, but the dup function is identical. */
13084 case 'u': /* actually an HV, but the dup function is identical. */
13085 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
13088 /* This is cheating. */
13089 Newx(d->data[i], 1, struct regnode_charclass_class);
13090 StructCopy(ri->data->data[i], d->data[i],
13091 struct regnode_charclass_class);
13092 reti->regstclass = (regnode*)d->data[i];
13095 /* Compiled op trees are readonly and in shared memory,
13096 and can thus be shared without duplication. */
13098 d->data[i] = (void*)OpREFCNT_inc((OP*)ri->data->data[i]);
13102 /* Trie stclasses are readonly and can thus be shared
13103 * without duplication. We free the stclass in pregfree
13104 * when the corresponding reg_ac_data struct is freed.
13106 reti->regstclass= ri->regstclass;
13110 ((reg_trie_data*)ri->data->data[i])->refcount++;
13114 d->data[i] = ri->data->data[i];
13117 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
13126 reti->name_list_idx = ri->name_list_idx;
13128 #ifdef RE_TRACK_PATTERN_OFFSETS
13129 if (ri->u.offsets) {
13130 Newx(reti->u.offsets, 2*len+1, U32);
13131 Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
13134 SetProgLen(reti,len);
13137 return (void*)reti;
13140 #endif /* USE_ITHREADS */
13142 #ifndef PERL_IN_XSUB_RE
13145 - regnext - dig the "next" pointer out of a node
13148 Perl_regnext(pTHX_ register regnode *p)
13151 register I32 offset;
13156 if (OP(p) > REGNODE_MAX) { /* regnode.type is unsigned */
13157 Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX);
13160 offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
13169 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
13172 STRLEN l1 = strlen(pat1);
13173 STRLEN l2 = strlen(pat2);
13176 const char *message;
13178 PERL_ARGS_ASSERT_RE_CROAK2;
13184 Copy(pat1, buf, l1 , char);
13185 Copy(pat2, buf + l1, l2 , char);
13186 buf[l1 + l2] = '\n';
13187 buf[l1 + l2 + 1] = '\0';
13189 /* ANSI variant takes additional second argument */
13190 va_start(args, pat2);
13194 msv = vmess(buf, &args);
13196 message = SvPV_const(msv,l1);
13199 Copy(message, buf, l1 , char);
13200 buf[l1-1] = '\0'; /* Overwrite \n */
13201 Perl_croak(aTHX_ "%s", buf);
13204 /* XXX Here's a total kludge. But we need to re-enter for swash routines. */
13206 #ifndef PERL_IN_XSUB_RE
13208 Perl_save_re_context(pTHX)
13212 struct re_save_state *state;
13214 SAVEVPTR(PL_curcop);
13215 SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
13217 state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
13218 PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
13219 SSPUSHUV(SAVEt_RE_STATE);
13221 Copy(&PL_reg_state, state, 1, struct re_save_state);
13223 PL_reg_start_tmp = 0;
13224 PL_reg_start_tmpl = 0;
13225 PL_reg_oldsaved = NULL;
13226 PL_reg_oldsavedlen = 0;
13227 PL_reg_maxiter = 0;
13228 PL_reg_leftiter = 0;
13229 PL_reg_poscache = NULL;
13230 PL_reg_poscache_size = 0;
13231 #ifdef PERL_OLD_COPY_ON_WRITE
13235 /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
13237 const REGEXP * const rx = PM_GETRE(PL_curpm);
13240 for (i = 1; i <= RX_NPARENS(rx); i++) {
13241 char digits[TYPE_CHARS(long)];
13242 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
13243 GV *const *const gvp
13244 = (GV**)hv_fetch(PL_defstash, digits, len, 0);
13247 GV * const gv = *gvp;
13248 if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
13258 clear_re(pTHX_ void *r)
13261 ReREFCNT_dec((REGEXP *)r);
13267 S_put_byte(pTHX_ SV *sv, int c)
13269 PERL_ARGS_ASSERT_PUT_BYTE;
13271 /* Our definition of isPRINT() ignores locales, so only bytes that are
13272 not part of UTF-8 are considered printable. I assume that the same
13273 holds for UTF-EBCDIC.
13274 Also, code point 255 is not printable in either (it's E0 in EBCDIC,
13275 which Wikipedia says:
13277 EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all
13278 ones (binary 1111 1111, hexadecimal FF). It is similar, but not
13279 identical, to the ASCII delete (DEL) or rubout control character.
13280 ) So the old condition can be simplified to !isPRINT(c) */
13283 Perl_sv_catpvf(aTHX_ sv, "\\x%02x", c);
13286 Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c);
13290 const char string = c;
13291 if (c == '-' || c == ']' || c == '\\' || c == '^')
13292 sv_catpvs(sv, "\\");
13293 sv_catpvn(sv, &string, 1);
13298 #define CLEAR_OPTSTART \
13299 if (optstart) STMT_START { \
13300 DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
13304 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
13306 STATIC const regnode *
13307 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
13308 const regnode *last, const regnode *plast,
13309 SV* sv, I32 indent, U32 depth)
13312 register U8 op = PSEUDO; /* Arbitrary non-END op. */
13313 register const regnode *next;
13314 const regnode *optstart= NULL;
13316 RXi_GET_DECL(r,ri);
13317 GET_RE_DEBUG_FLAGS_DECL;
13319 PERL_ARGS_ASSERT_DUMPUNTIL;
13321 #ifdef DEBUG_DUMPUNTIL
13322 PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
13323 last ? last-start : 0,plast ? plast-start : 0);
13326 if (plast && plast < last)
13329 while (PL_regkind[op] != END && (!last || node < last)) {
13330 /* While that wasn't END last time... */
13333 if (op == CLOSE || op == WHILEM)
13335 next = regnext((regnode *)node);
13338 if (OP(node) == OPTIMIZED) {
13339 if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
13346 regprop(r, sv, node);
13347 PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
13348 (int)(2*indent + 1), "", SvPVX_const(sv));
13350 if (OP(node) != OPTIMIZED) {
13351 if (next == NULL) /* Next ptr. */
13352 PerlIO_printf(Perl_debug_log, " (0)");
13353 else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
13354 PerlIO_printf(Perl_debug_log, " (FAIL)");
13356 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
13357 (void)PerlIO_putc(Perl_debug_log, '\n');
13361 if (PL_regkind[(U8)op] == BRANCHJ) {
13364 register const regnode *nnode = (OP(next) == LONGJMP
13365 ? regnext((regnode *)next)
13367 if (last && nnode > last)
13369 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
13372 else if (PL_regkind[(U8)op] == BRANCH) {
13374 DUMPUNTIL(NEXTOPER(node), next);
13376 else if ( PL_regkind[(U8)op] == TRIE ) {
13377 const regnode *this_trie = node;
13378 const char op = OP(node);
13379 const U32 n = ARG(node);
13380 const reg_ac_data * const ac = op>=AHOCORASICK ?
13381 (reg_ac_data *)ri->data->data[n] :
13383 const reg_trie_data * const trie =
13384 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
13386 AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
13388 const regnode *nextbranch= NULL;
13391 for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
13392 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
13394 PerlIO_printf(Perl_debug_log, "%*s%s ",
13395 (int)(2*(indent+3)), "",
13396 elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
13397 PL_colors[0], PL_colors[1],
13398 (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
13399 PERL_PV_PRETTY_ELLIPSES |
13400 PERL_PV_PRETTY_LTGT
13405 U16 dist= trie->jump[word_idx+1];
13406 PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
13407 (UV)((dist ? this_trie + dist : next) - start));
13410 nextbranch= this_trie + trie->jump[0];
13411 DUMPUNTIL(this_trie + dist, nextbranch);
13413 if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
13414 nextbranch= regnext((regnode *)nextbranch);
13416 PerlIO_printf(Perl_debug_log, "\n");
13419 if (last && next > last)
13424 else if ( op == CURLY ) { /* "next" might be very big: optimizer */
13425 DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
13426 NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
13428 else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
13430 DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
13432 else if ( op == PLUS || op == STAR) {
13433 DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
13435 else if (PL_regkind[(U8)op] == ANYOF) {
13436 /* arglen 1 + class block */
13437 node += 1 + ((ANYOF_FLAGS(node) & ANYOF_CLASS)
13438 ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
13439 node = NEXTOPER(node);
13441 else if (PL_regkind[(U8)op] == EXACT) {
13442 /* Literal string, where present. */
13443 node += NODE_SZ_STR(node) - 1;
13444 node = NEXTOPER(node);
13447 node = NEXTOPER(node);
13448 node += regarglen[(U8)op];
13450 if (op == CURLYX || op == OPEN)
13454 #ifdef DEBUG_DUMPUNTIL
13455 PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
13460 #endif /* DEBUGGING */
13464 * c-indentation-style: bsd
13465 * c-basic-offset: 4
13466 * indent-tabs-mode: t
13469 * ex: set ts=8 sts=4 sw=4 noet: