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"
95 # if defined(BUGGY_MSC6)
96 /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
97 # pragma optimize("a",off)
98 /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
99 # pragma optimize("w",on )
100 # endif /* BUGGY_MSC6 */
104 #define STATIC static
107 typedef struct RExC_state_t {
108 U32 flags; /* are we folding, multilining? */
109 char *precomp; /* uncompiled string. */
110 REGEXP *rx_sv; /* The SV that is the regexp. */
111 regexp *rx; /* perl core regexp structure */
112 regexp_internal *rxi; /* internal data for regexp object pprivate field */
113 char *start; /* Start of input for compile */
114 char *end; /* End of input for compile */
115 char *parse; /* Input-scan pointer. */
116 I32 whilem_seen; /* number of WHILEM in this expr */
117 regnode *emit_start; /* Start of emitted-code area */
118 regnode *emit_bound; /* First regnode outside of the allocated space */
119 regnode *emit; /* Code-emit pointer; ®dummy = don't = compiling */
120 I32 naughty; /* How bad is this pattern? */
121 I32 sawback; /* Did we see \1, ...? */
123 I32 size; /* Code size. */
124 I32 npar; /* Capture buffer count, (OPEN). */
125 I32 cpar; /* Capture buffer count, (CLOSE). */
126 I32 nestroot; /* root parens we are in - used by accept */
130 regnode **open_parens; /* pointers to open parens */
131 regnode **close_parens; /* pointers to close parens */
132 regnode *opend; /* END node in program */
133 I32 utf8; /* whether the pattern is utf8 or not */
134 I32 orig_utf8; /* whether the pattern was originally in utf8 */
135 /* XXX use this for future optimisation of case
136 * where pattern must be upgraded to utf8. */
137 I32 uni_semantics; /* If a d charset modifier should use unicode
138 rules, even if the pattern is not in
140 HV *paren_names; /* Paren names */
142 regnode **recurse; /* Recurse regops */
143 I32 recurse_count; /* Number of recurse regops */
146 char *starttry; /* -Dr: where regtry was called. */
147 #define RExC_starttry (pRExC_state->starttry)
150 const char *lastparse;
152 AV *paren_name_list; /* idx -> name */
153 #define RExC_lastparse (pRExC_state->lastparse)
154 #define RExC_lastnum (pRExC_state->lastnum)
155 #define RExC_paren_name_list (pRExC_state->paren_name_list)
159 #define RExC_flags (pRExC_state->flags)
160 #define RExC_precomp (pRExC_state->precomp)
161 #define RExC_rx_sv (pRExC_state->rx_sv)
162 #define RExC_rx (pRExC_state->rx)
163 #define RExC_rxi (pRExC_state->rxi)
164 #define RExC_start (pRExC_state->start)
165 #define RExC_end (pRExC_state->end)
166 #define RExC_parse (pRExC_state->parse)
167 #define RExC_whilem_seen (pRExC_state->whilem_seen)
168 #ifdef RE_TRACK_PATTERN_OFFSETS
169 #define RExC_offsets (pRExC_state->rxi->u.offsets) /* I am not like the others */
171 #define RExC_emit (pRExC_state->emit)
172 #define RExC_emit_start (pRExC_state->emit_start)
173 #define RExC_emit_bound (pRExC_state->emit_bound)
174 #define RExC_naughty (pRExC_state->naughty)
175 #define RExC_sawback (pRExC_state->sawback)
176 #define RExC_seen (pRExC_state->seen)
177 #define RExC_size (pRExC_state->size)
178 #define RExC_npar (pRExC_state->npar)
179 #define RExC_nestroot (pRExC_state->nestroot)
180 #define RExC_extralen (pRExC_state->extralen)
181 #define RExC_seen_zerolen (pRExC_state->seen_zerolen)
182 #define RExC_seen_evals (pRExC_state->seen_evals)
183 #define RExC_utf8 (pRExC_state->utf8)
184 #define RExC_uni_semantics (pRExC_state->uni_semantics)
185 #define RExC_orig_utf8 (pRExC_state->orig_utf8)
186 #define RExC_open_parens (pRExC_state->open_parens)
187 #define RExC_close_parens (pRExC_state->close_parens)
188 #define RExC_opend (pRExC_state->opend)
189 #define RExC_paren_names (pRExC_state->paren_names)
190 #define RExC_recurse (pRExC_state->recurse)
191 #define RExC_recurse_count (pRExC_state->recurse_count)
192 #define RExC_in_lookbehind (pRExC_state->in_lookbehind)
195 #define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?')
196 #define ISMULT2(s) ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
197 ((*s) == '{' && regcurly(s)))
200 #undef SPSTART /* dratted cpp namespace... */
203 * Flags to be passed up and down.
205 #define WORST 0 /* Worst case. */
206 #define HASWIDTH 0x01 /* Known to match non-null strings. */
208 /* Simple enough to be STAR/PLUS operand, in an EXACT node must be a single
209 * character, and if utf8, must be invariant. Note that this is not the same thing as REGNODE_SIMPLE */
211 #define SPSTART 0x04 /* Starts with * or +. */
212 #define TRYAGAIN 0x08 /* Weeded out a declaration. */
213 #define POSTPONED 0x10 /* (?1),(?&name), (??{...}) or similar */
215 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
217 /* whether trie related optimizations are enabled */
218 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
219 #define TRIE_STUDY_OPT
220 #define FULL_TRIE_STUDY
226 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
227 #define PBITVAL(paren) (1 << ((paren) & 7))
228 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
229 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
230 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
232 /* If not already in utf8, do a longjmp back to the beginning */
233 #define UTF8_LONGJMP 42 /* Choose a value not likely to ever conflict */
234 #define REQUIRE_UTF8 STMT_START { \
235 if (! UTF) JMPENV_JUMP(UTF8_LONGJMP); \
238 /* About scan_data_t.
240 During optimisation we recurse through the regexp program performing
241 various inplace (keyhole style) optimisations. In addition study_chunk
242 and scan_commit populate this data structure with information about
243 what strings MUST appear in the pattern. We look for the longest
244 string that must appear at a fixed location, and we look for the
245 longest string that may appear at a floating location. So for instance
250 Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
251 strings (because they follow a .* construct). study_chunk will identify
252 both FOO and BAR as being the longest fixed and floating strings respectively.
254 The strings can be composites, for instance
258 will result in a composite fixed substring 'foo'.
260 For each string some basic information is maintained:
262 - offset or min_offset
263 This is the position the string must appear at, or not before.
264 It also implicitly (when combined with minlenp) tells us how many
265 characters must match before the string we are searching for.
266 Likewise when combined with minlenp and the length of the string it
267 tells us how many characters must appear after the string we have
271 Only used for floating strings. This is the rightmost point that
272 the string can appear at. If set to I32 max it indicates that the
273 string can occur infinitely far to the right.
276 A pointer to the minimum length of the pattern that the string
277 was found inside. This is important as in the case of positive
278 lookahead or positive lookbehind we can have multiple patterns
283 The minimum length of the pattern overall is 3, the minimum length
284 of the lookahead part is 3, but the minimum length of the part that
285 will actually match is 1. So 'FOO's minimum length is 3, but the
286 minimum length for the F is 1. This is important as the minimum length
287 is used to determine offsets in front of and behind the string being
288 looked for. Since strings can be composites this is the length of the
289 pattern at the time it was committed with a scan_commit. Note that
290 the length is calculated by study_chunk, so that the minimum lengths
291 are not known until the full pattern has been compiled, thus the
292 pointer to the value.
296 In the case of lookbehind the string being searched for can be
297 offset past the start point of the final matching string.
298 If this value was just blithely removed from the min_offset it would
299 invalidate some of the calculations for how many chars must match
300 before or after (as they are derived from min_offset and minlen and
301 the length of the string being searched for).
302 When the final pattern is compiled and the data is moved from the
303 scan_data_t structure into the regexp structure the information
304 about lookbehind is factored in, with the information that would
305 have been lost precalculated in the end_shift field for the
308 The fields pos_min and pos_delta are used to store the minimum offset
309 and the delta to the maximum offset at the current point in the pattern.
313 typedef struct scan_data_t {
314 /*I32 len_min; unused */
315 /*I32 len_delta; unused */
319 I32 last_end; /* min value, <0 unless valid. */
322 SV **longest; /* Either &l_fixed, or &l_float. */
323 SV *longest_fixed; /* longest fixed string found in pattern */
324 I32 offset_fixed; /* offset where it starts */
325 I32 *minlen_fixed; /* pointer to the minlen relevant to the string */
326 I32 lookbehind_fixed; /* is the position of the string modfied by LB */
327 SV *longest_float; /* longest floating string found in pattern */
328 I32 offset_float_min; /* earliest point in string it can appear */
329 I32 offset_float_max; /* latest point in string it can appear */
330 I32 *minlen_float; /* pointer to the minlen relevant to the string */
331 I32 lookbehind_float; /* is the position of the string modified by LB */
335 struct regnode_charclass_class *start_class;
339 * Forward declarations for pregcomp()'s friends.
342 static const scan_data_t zero_scan_data =
343 { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
345 #define SF_BEFORE_EOL (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
346 #define SF_BEFORE_SEOL 0x0001
347 #define SF_BEFORE_MEOL 0x0002
348 #define SF_FIX_BEFORE_EOL (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
349 #define SF_FL_BEFORE_EOL (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
352 # define SF_FIX_SHIFT_EOL (0+2)
353 # define SF_FL_SHIFT_EOL (0+4)
355 # define SF_FIX_SHIFT_EOL (+2)
356 # define SF_FL_SHIFT_EOL (+4)
359 #define SF_FIX_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
360 #define SF_FIX_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
362 #define SF_FL_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
363 #define SF_FL_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
364 #define SF_IS_INF 0x0040
365 #define SF_HAS_PAR 0x0080
366 #define SF_IN_PAR 0x0100
367 #define SF_HAS_EVAL 0x0200
368 #define SCF_DO_SUBSTR 0x0400
369 #define SCF_DO_STCLASS_AND 0x0800
370 #define SCF_DO_STCLASS_OR 0x1000
371 #define SCF_DO_STCLASS (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
372 #define SCF_WHILEM_VISITED_POS 0x2000
374 #define SCF_TRIE_RESTUDY 0x4000 /* Do restudy? */
375 #define SCF_SEEN_ACCEPT 0x8000
377 #define UTF cBOOL(RExC_utf8)
378 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
379 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
380 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_DEPENDS_CHARSET)
381 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags) >= REGEX_UNICODE_CHARSET)
382 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_RESTRICTED_CHARSET)
384 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
386 #define OOB_UNICODE 12345678
387 #define OOB_NAMEDCLASS -1
389 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
390 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
393 /* length of regex to show in messages that don't mark a position within */
394 #define RegexLengthToShowInErrorMessages 127
397 * If MARKER[12] are adjusted, be sure to adjust the constants at the top
398 * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
399 * op/pragma/warn/regcomp.
401 #define MARKER1 "<-- HERE" /* marker as it appears in the description */
402 #define MARKER2 " <-- HERE " /* marker as it appears within the regex */
404 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
407 * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
408 * arg. Show regex, up to a maximum length. If it's too long, chop and add
411 #define _FAIL(code) STMT_START { \
412 const char *ellipses = ""; \
413 IV len = RExC_end - RExC_precomp; \
416 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
417 if (len > RegexLengthToShowInErrorMessages) { \
418 /* chop 10 shorter than the max, to ensure meaning of "..." */ \
419 len = RegexLengthToShowInErrorMessages - 10; \
425 #define FAIL(msg) _FAIL( \
426 Perl_croak(aTHX_ "%s in regex m/%.*s%s/", \
427 msg, (int)len, RExC_precomp, ellipses))
429 #define FAIL2(msg,arg) _FAIL( \
430 Perl_croak(aTHX_ msg " in regex m/%.*s%s/", \
431 arg, (int)len, RExC_precomp, ellipses))
434 * Simple_vFAIL -- like FAIL, but marks the current location in the scan
436 #define Simple_vFAIL(m) STMT_START { \
437 const IV offset = RExC_parse - RExC_precomp; \
438 Perl_croak(aTHX_ "%s" REPORT_LOCATION, \
439 m, (int)offset, RExC_precomp, RExC_precomp + offset); \
443 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
445 #define vFAIL(m) STMT_START { \
447 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
452 * Like Simple_vFAIL(), but accepts two arguments.
454 #define Simple_vFAIL2(m,a1) STMT_START { \
455 const IV offset = RExC_parse - RExC_precomp; \
456 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, \
457 (int)offset, RExC_precomp, RExC_precomp + offset); \
461 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
463 #define vFAIL2(m,a1) STMT_START { \
465 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
466 Simple_vFAIL2(m, a1); \
471 * Like Simple_vFAIL(), but accepts three arguments.
473 #define Simple_vFAIL3(m, a1, a2) STMT_START { \
474 const IV offset = RExC_parse - RExC_precomp; \
475 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, \
476 (int)offset, RExC_precomp, RExC_precomp + offset); \
480 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
482 #define vFAIL3(m,a1,a2) STMT_START { \
484 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
485 Simple_vFAIL3(m, a1, a2); \
489 * Like Simple_vFAIL(), but accepts four arguments.
491 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START { \
492 const IV offset = RExC_parse - RExC_precomp; \
493 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3, \
494 (int)offset, RExC_precomp, RExC_precomp + offset); \
497 #define ckWARNreg(loc,m) STMT_START { \
498 const IV offset = loc - RExC_precomp; \
499 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
500 (int)offset, RExC_precomp, RExC_precomp + offset); \
503 #define ckWARNregdep(loc,m) STMT_START { \
504 const IV offset = loc - RExC_precomp; \
505 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \
507 (int)offset, RExC_precomp, RExC_precomp + offset); \
510 #define ckWARN2reg(loc, m, a1) STMT_START { \
511 const IV offset = loc - RExC_precomp; \
512 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
513 a1, (int)offset, RExC_precomp, RExC_precomp + offset); \
516 #define vWARN3(loc, m, a1, a2) STMT_START { \
517 const IV offset = loc - RExC_precomp; \
518 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
519 a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset); \
522 #define ckWARN3reg(loc, m, a1, a2) STMT_START { \
523 const IV offset = loc - RExC_precomp; \
524 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
525 a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset); \
528 #define vWARN4(loc, m, a1, a2, a3) STMT_START { \
529 const IV offset = loc - RExC_precomp; \
530 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
531 a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
534 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START { \
535 const IV offset = loc - RExC_precomp; \
536 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
537 a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
540 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START { \
541 const IV offset = loc - RExC_precomp; \
542 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
543 a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
547 /* Allow for side effects in s */
548 #define REGC(c,s) STMT_START { \
549 if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
552 /* Macros for recording node offsets. 20001227 mjd@plover.com
553 * Nodes are numbered 1, 2, 3, 4. Node #n's position is recorded in
554 * element 2*n-1 of the array. Element #2n holds the byte length node #n.
555 * Element 0 holds the number n.
556 * Position is 1 indexed.
558 #ifndef RE_TRACK_PATTERN_OFFSETS
559 #define Set_Node_Offset_To_R(node,byte)
560 #define Set_Node_Offset(node,byte)
561 #define Set_Cur_Node_Offset
562 #define Set_Node_Length_To_R(node,len)
563 #define Set_Node_Length(node,len)
564 #define Set_Node_Cur_Length(node)
565 #define Node_Offset(n)
566 #define Node_Length(n)
567 #define Set_Node_Offset_Length(node,offset,len)
568 #define ProgLen(ri) ri->u.proglen
569 #define SetProgLen(ri,x) ri->u.proglen = x
571 #define ProgLen(ri) ri->u.offsets[0]
572 #define SetProgLen(ri,x) ri->u.offsets[0] = x
573 #define Set_Node_Offset_To_R(node,byte) STMT_START { \
575 MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n", \
576 __LINE__, (int)(node), (int)(byte))); \
578 Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
580 RExC_offsets[2*(node)-1] = (byte); \
585 #define Set_Node_Offset(node,byte) \
586 Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
587 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
589 #define Set_Node_Length_To_R(node,len) STMT_START { \
591 MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n", \
592 __LINE__, (int)(node), (int)(len))); \
594 Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
596 RExC_offsets[2*(node)] = (len); \
601 #define Set_Node_Length(node,len) \
602 Set_Node_Length_To_R((node)-RExC_emit_start, len)
603 #define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
604 #define Set_Node_Cur_Length(node) \
605 Set_Node_Length(node, RExC_parse - parse_start)
607 /* Get offsets and lengths */
608 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
609 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
611 #define Set_Node_Offset_Length(node,offset,len) STMT_START { \
612 Set_Node_Offset_To_R((node)-RExC_emit_start, (offset)); \
613 Set_Node_Length_To_R((node)-RExC_emit_start, (len)); \
617 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
618 #define EXPERIMENTAL_INPLACESCAN
619 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
621 #define DEBUG_STUDYDATA(str,data,depth) \
622 DEBUG_OPTIMISE_MORE_r(if(data){ \
623 PerlIO_printf(Perl_debug_log, \
624 "%*s" str "Pos:%"IVdf"/%"IVdf \
625 " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s", \
626 (int)(depth)*2, "", \
627 (IV)((data)->pos_min), \
628 (IV)((data)->pos_delta), \
629 (UV)((data)->flags), \
630 (IV)((data)->whilem_c), \
631 (IV)((data)->last_closep ? *((data)->last_closep) : -1), \
632 is_inf ? "INF " : "" \
634 if ((data)->last_found) \
635 PerlIO_printf(Perl_debug_log, \
636 "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
637 " %sFloat: '%s' @ %"IVdf"/%"IVdf"", \
638 SvPVX_const((data)->last_found), \
639 (IV)((data)->last_end), \
640 (IV)((data)->last_start_min), \
641 (IV)((data)->last_start_max), \
642 ((data)->longest && \
643 (data)->longest==&((data)->longest_fixed)) ? "*" : "", \
644 SvPVX_const((data)->longest_fixed), \
645 (IV)((data)->offset_fixed), \
646 ((data)->longest && \
647 (data)->longest==&((data)->longest_float)) ? "*" : "", \
648 SvPVX_const((data)->longest_float), \
649 (IV)((data)->offset_float_min), \
650 (IV)((data)->offset_float_max) \
652 PerlIO_printf(Perl_debug_log,"\n"); \
655 static void clear_re(pTHX_ void *r);
657 /* Mark that we cannot extend a found fixed substring at this point.
658 Update the longest found anchored substring and the longest found
659 floating substrings if needed. */
662 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp, int is_inf)
664 const STRLEN l = CHR_SVLEN(data->last_found);
665 const STRLEN old_l = CHR_SVLEN(*data->longest);
666 GET_RE_DEBUG_FLAGS_DECL;
668 PERL_ARGS_ASSERT_SCAN_COMMIT;
670 if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
671 SvSetMagicSV(*data->longest, data->last_found);
672 if (*data->longest == data->longest_fixed) {
673 data->offset_fixed = l ? data->last_start_min : data->pos_min;
674 if (data->flags & SF_BEFORE_EOL)
676 |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
678 data->flags &= ~SF_FIX_BEFORE_EOL;
679 data->minlen_fixed=minlenp;
680 data->lookbehind_fixed=0;
682 else { /* *data->longest == data->longest_float */
683 data->offset_float_min = l ? data->last_start_min : data->pos_min;
684 data->offset_float_max = (l
685 ? data->last_start_max
686 : data->pos_min + data->pos_delta);
687 if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX)
688 data->offset_float_max = I32_MAX;
689 if (data->flags & SF_BEFORE_EOL)
691 |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
693 data->flags &= ~SF_FL_BEFORE_EOL;
694 data->minlen_float=minlenp;
695 data->lookbehind_float=0;
698 SvCUR_set(data->last_found, 0);
700 SV * const sv = data->last_found;
701 if (SvUTF8(sv) && SvMAGICAL(sv)) {
702 MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
708 data->flags &= ~SF_BEFORE_EOL;
709 DEBUG_STUDYDATA("commit: ",data,0);
712 /* Can match anything (initialization) */
714 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
716 PERL_ARGS_ASSERT_CL_ANYTHING;
718 ANYOF_CLASS_ZERO(cl);
719 ANYOF_BITMAP_SETALL(cl);
720 cl->flags = ANYOF_EOS|ANYOF_UNICODE_ALL|ANYOF_LOC_NONBITMAP_FOLD|ANYOF_NON_UTF8_LATIN1_ALL;
722 cl->flags |= ANYOF_LOCALE;
725 /* Can match anything (initialization) */
727 S_cl_is_anything(const struct regnode_charclass_class *cl)
731 PERL_ARGS_ASSERT_CL_IS_ANYTHING;
733 for (value = 0; value <= ANYOF_MAX; value += 2)
734 if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
736 if (!(cl->flags & ANYOF_UNICODE_ALL))
738 if (!ANYOF_BITMAP_TESTALLSET((const void*)cl))
743 /* Can match anything (initialization) */
745 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
747 PERL_ARGS_ASSERT_CL_INIT;
749 Zero(cl, 1, struct regnode_charclass_class);
751 cl_anything(pRExC_state, cl);
755 S_cl_init_zero(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
757 PERL_ARGS_ASSERT_CL_INIT_ZERO;
759 Zero(cl, 1, struct regnode_charclass_class);
761 cl_anything(pRExC_state, cl);
763 cl->flags |= ANYOF_LOCALE;
766 /* 'And' a given class with another one. Can create false positives */
767 /* We assume that cl is not inverted */
769 S_cl_and(struct regnode_charclass_class *cl,
770 const struct regnode_charclass_class *and_with)
772 PERL_ARGS_ASSERT_CL_AND;
774 assert(and_with->type == ANYOF);
776 if (!(ANYOF_CLASS_TEST_ANY_SET(and_with))
777 && !(ANYOF_CLASS_TEST_ANY_SET(cl))
778 && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
779 && !(and_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
780 && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) {
783 if (and_with->flags & ANYOF_INVERT)
784 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
785 cl->bitmap[i] &= ~and_with->bitmap[i];
787 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
788 cl->bitmap[i] &= and_with->bitmap[i];
789 } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
790 if (!(and_with->flags & ANYOF_EOS))
791 cl->flags &= ~ANYOF_EOS;
793 if (!(and_with->flags & ANYOF_LOC_NONBITMAP_FOLD))
794 cl->flags &= ~ANYOF_LOC_NONBITMAP_FOLD;
795 if (!(and_with->flags & ANYOF_NON_UTF8_LATIN1_ALL))
796 cl->flags &= ~ANYOF_NON_UTF8_LATIN1_ALL;
798 if (cl->flags & ANYOF_UNICODE_ALL
799 && and_with->flags & ANYOF_NONBITMAP
800 && !(and_with->flags & ANYOF_INVERT))
802 if (! (and_with->flags & ANYOF_UNICODE_ALL)) {
803 cl->flags &= ~ANYOF_UNICODE_ALL;
805 cl->flags |= and_with->flags & ANYOF_NONBITMAP; /* field is 2 bits; use
808 ARG_SET(cl, ARG(and_with));
810 if (!(and_with->flags & ANYOF_UNICODE_ALL) &&
811 !(and_with->flags & ANYOF_INVERT))
812 cl->flags &= ~ANYOF_UNICODE_ALL;
813 if (!(and_with->flags & (ANYOF_NONBITMAP|ANYOF_UNICODE_ALL)) &&
814 !(and_with->flags & ANYOF_INVERT))
815 cl->flags &= ~ANYOF_NONBITMAP;
818 /* 'OR' a given class with another one. Can create false positives */
819 /* We assume that cl is not inverted */
821 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
823 PERL_ARGS_ASSERT_CL_OR;
825 if (or_with->flags & ANYOF_INVERT) {
827 * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
828 * <= (B1 | !B2) | (CL1 | !CL2)
829 * which is wasteful if CL2 is small, but we ignore CL2:
830 * (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
831 * XXXX Can we handle case-fold? Unclear:
832 * (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
833 * (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
835 if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
836 && !(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
837 && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD) ) {
840 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
841 cl->bitmap[i] |= ~or_with->bitmap[i];
842 } /* XXXX: logic is complicated otherwise */
844 cl_anything(pRExC_state, cl);
847 /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
848 if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
849 && (!(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
850 || (cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) ) {
853 /* OR char bitmap and class bitmap separately */
854 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
855 cl->bitmap[i] |= or_with->bitmap[i];
856 if (ANYOF_CLASS_TEST_ANY_SET(or_with)) {
857 for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
858 cl->classflags[i] |= or_with->classflags[i];
859 cl->flags |= ANYOF_CLASS;
862 else { /* XXXX: logic is complicated, leave it along for a moment. */
863 cl_anything(pRExC_state, cl);
866 if (or_with->flags & ANYOF_EOS)
867 cl->flags |= ANYOF_EOS;
868 if (!(or_with->flags & ANYOF_NON_UTF8_LATIN1_ALL))
869 cl->flags |= ANYOF_NON_UTF8_LATIN1_ALL;
871 if (or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
872 cl->flags |= ANYOF_LOC_NONBITMAP_FOLD;
874 /* If both nodes match something outside the bitmap, but what they match
875 * outside is not the same pointer, and hence not easily compared, give up
876 * and allow the start class to match everything outside the bitmap */
877 if (cl->flags & ANYOF_NONBITMAP && or_with->flags & ANYOF_NONBITMAP &&
878 ARG(cl) != ARG(or_with)) {
879 cl->flags |= ANYOF_UNICODE_ALL;
882 if (or_with->flags & ANYOF_UNICODE_ALL) {
883 cl->flags |= ANYOF_UNICODE_ALL;
887 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
888 #define TRIE_LIST_CUR(state) ( TRIE_LIST_ITEM( state, 0 ).forid )
889 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
890 #define TRIE_LIST_USED(idx) ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
895 dump_trie(trie,widecharmap,revcharmap)
896 dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
897 dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
899 These routines dump out a trie in a somewhat readable format.
900 The _interim_ variants are used for debugging the interim
901 tables that are used to generate the final compressed
902 representation which is what dump_trie expects.
904 Part of the reason for their existence is to provide a form
905 of documentation as to how the different representations function.
910 Dumps the final compressed table form of the trie to Perl_debug_log.
911 Used for debugging make_trie().
915 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
916 AV *revcharmap, U32 depth)
919 SV *sv=sv_newmortal();
920 int colwidth= widecharmap ? 6 : 4;
922 GET_RE_DEBUG_FLAGS_DECL;
924 PERL_ARGS_ASSERT_DUMP_TRIE;
926 PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
927 (int)depth * 2 + 2,"",
928 "Match","Base","Ofs" );
930 for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
931 SV ** const tmp = av_fetch( revcharmap, state, 0);
933 PerlIO_printf( Perl_debug_log, "%*s",
935 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
936 PL_colors[0], PL_colors[1],
937 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
938 PERL_PV_ESCAPE_FIRSTCHAR
943 PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
944 (int)depth * 2 + 2,"");
946 for( state = 0 ; state < trie->uniquecharcount ; state++ )
947 PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
948 PerlIO_printf( Perl_debug_log, "\n");
950 for( state = 1 ; state < trie->statecount ; state++ ) {
951 const U32 base = trie->states[ state ].trans.base;
953 PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
955 if ( trie->states[ state ].wordnum ) {
956 PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum );
958 PerlIO_printf( Perl_debug_log, "%6s", "" );
961 PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
966 while( ( base + ofs < trie->uniquecharcount ) ||
967 ( base + ofs - trie->uniquecharcount < trie->lasttrans
968 && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
971 PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
973 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
974 if ( ( base + ofs >= trie->uniquecharcount ) &&
975 ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
976 trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
978 PerlIO_printf( Perl_debug_log, "%*"UVXf,
980 (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
982 PerlIO_printf( Perl_debug_log, "%*s",colwidth," ." );
986 PerlIO_printf( Perl_debug_log, "]");
989 PerlIO_printf( Perl_debug_log, "\n" );
991 PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=", (int)depth*2, "");
992 for (word=1; word <= trie->wordcount; word++) {
993 PerlIO_printf(Perl_debug_log, " %d:(%d,%d)",
994 (int)word, (int)(trie->wordinfo[word].prev),
995 (int)(trie->wordinfo[word].len));
997 PerlIO_printf(Perl_debug_log, "\n" );
1000 Dumps a fully constructed but uncompressed trie in list form.
1001 List tries normally only are used for construction when the number of
1002 possible chars (trie->uniquecharcount) is very high.
1003 Used for debugging make_trie().
1006 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
1007 HV *widecharmap, AV *revcharmap, U32 next_alloc,
1011 SV *sv=sv_newmortal();
1012 int colwidth= widecharmap ? 6 : 4;
1013 GET_RE_DEBUG_FLAGS_DECL;
1015 PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
1017 /* print out the table precompression. */
1018 PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
1019 (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
1020 "------:-----+-----------------\n" );
1022 for( state=1 ; state < next_alloc ; state ++ ) {
1025 PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
1026 (int)depth * 2 + 2,"", (UV)state );
1027 if ( ! trie->states[ state ].wordnum ) {
1028 PerlIO_printf( Perl_debug_log, "%5s| ","");
1030 PerlIO_printf( Perl_debug_log, "W%4x| ",
1031 trie->states[ state ].wordnum
1034 for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
1035 SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
1037 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
1039 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1040 PL_colors[0], PL_colors[1],
1041 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1042 PERL_PV_ESCAPE_FIRSTCHAR
1044 TRIE_LIST_ITEM(state,charid).forid,
1045 (UV)TRIE_LIST_ITEM(state,charid).newstate
1048 PerlIO_printf(Perl_debug_log, "\n%*s| ",
1049 (int)((depth * 2) + 14), "");
1052 PerlIO_printf( Perl_debug_log, "\n");
1057 Dumps a fully constructed but uncompressed trie in table form.
1058 This is the normal DFA style state transition table, with a few
1059 twists to facilitate compression later.
1060 Used for debugging make_trie().
1063 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
1064 HV *widecharmap, AV *revcharmap, U32 next_alloc,
1069 SV *sv=sv_newmortal();
1070 int colwidth= widecharmap ? 6 : 4;
1071 GET_RE_DEBUG_FLAGS_DECL;
1073 PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
1076 print out the table precompression so that we can do a visual check
1077 that they are identical.
1080 PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
1082 for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1083 SV ** const tmp = av_fetch( revcharmap, charid, 0);
1085 PerlIO_printf( Perl_debug_log, "%*s",
1087 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1088 PL_colors[0], PL_colors[1],
1089 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1090 PERL_PV_ESCAPE_FIRSTCHAR
1096 PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
1098 for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1099 PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
1102 PerlIO_printf( Perl_debug_log, "\n" );
1104 for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1106 PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ",
1107 (int)depth * 2 + 2,"",
1108 (UV)TRIE_NODENUM( state ) );
1110 for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1111 UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1113 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1115 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1117 if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1118 PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
1120 PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check,
1121 trie->states[ TRIE_NODENUM( state ) ].wordnum );
1129 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1130 startbranch: the first branch in the whole branch sequence
1131 first : start branch of sequence of branch-exact nodes.
1132 May be the same as startbranch
1133 last : Thing following the last branch.
1134 May be the same as tail.
1135 tail : item following the branch sequence
1136 count : words in the sequence
1137 flags : currently the OP() type we will be building one of /EXACT(|F|Fl)/
1138 depth : indent depth
1140 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1142 A trie is an N'ary tree where the branches are determined by digital
1143 decomposition of the key. IE, at the root node you look up the 1st character and
1144 follow that branch repeat until you find the end of the branches. Nodes can be
1145 marked as "accepting" meaning they represent a complete word. Eg:
1149 would convert into the following structure. Numbers represent states, letters
1150 following numbers represent valid transitions on the letter from that state, if
1151 the number is in square brackets it represents an accepting state, otherwise it
1152 will be in parenthesis.
1154 +-h->+-e->[3]-+-r->(8)-+-s->[9]
1158 (1) +-i->(6)-+-s->[7]
1160 +-s->(3)-+-h->(4)-+-e->[5]
1162 Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1164 This shows that when matching against the string 'hers' we will begin at state 1
1165 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1166 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1167 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1168 single traverse. We store a mapping from accepting to state to which word was
1169 matched, and then when we have multiple possibilities we try to complete the
1170 rest of the regex in the order in which they occured in the alternation.
1172 The only prior NFA like behaviour that would be changed by the TRIE support is
1173 the silent ignoring of duplicate alternations which are of the form:
1175 / (DUPE|DUPE) X? (?{ ... }) Y /x
1177 Thus EVAL blocks following a trie may be called a different number of times with
1178 and without the optimisation. With the optimisations dupes will be silently
1179 ignored. This inconsistent behaviour of EVAL type nodes is well established as
1180 the following demonstrates:
1182 'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1184 which prints out 'word' three times, but
1186 'words'=~/(word|word|word)(?{ print $1 })S/
1188 which doesnt print it out at all. This is due to other optimisations kicking in.
1190 Example of what happens on a structural level:
1192 The regexp /(ac|ad|ab)+/ will produce the following debug output:
1194 1: CURLYM[1] {1,32767}(18)
1205 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1206 and should turn into:
1208 1: CURLYM[1] {1,32767}(18)
1210 [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1218 Cases where tail != last would be like /(?foo|bar)baz/:
1228 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1229 and would end up looking like:
1232 [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1239 d = uvuni_to_utf8_flags(d, uv, 0);
1241 is the recommended Unicode-aware way of saying
1246 #define TRIE_STORE_REVCHAR \
1249 SV *zlopp = newSV(2); \
1250 unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp); \
1251 unsigned const char *const kapow = uvuni_to_utf8(flrbbbbb, uvc & 0xFF); \
1252 SvCUR_set(zlopp, kapow - flrbbbbb); \
1255 av_push(revcharmap, zlopp); \
1257 char ooooff = (char)uvc; \
1258 av_push(revcharmap, newSVpvn(&ooooff, 1)); \
1262 #define TRIE_READ_CHAR STMT_START { \
1266 if ( foldlen > 0 ) { \
1267 uvc = utf8n_to_uvuni( scan, UTF8_MAXLEN, &len, uniflags ); \
1272 uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
1273 uvc = to_uni_fold( uvc, foldbuf, &foldlen ); \
1274 foldlen -= UNISKIP( uvc ); \
1275 scan = foldbuf + UNISKIP( uvc ); \
1278 uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
1288 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START { \
1289 if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) { \
1290 U32 ging = TRIE_LIST_LEN( state ) *= 2; \
1291 Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1293 TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid; \
1294 TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns; \
1295 TRIE_LIST_CUR( state )++; \
1298 #define TRIE_LIST_NEW(state) STMT_START { \
1299 Newxz( trie->states[ state ].trans.list, \
1300 4, reg_trie_trans_le ); \
1301 TRIE_LIST_CUR( state ) = 1; \
1302 TRIE_LIST_LEN( state ) = 4; \
1305 #define TRIE_HANDLE_WORD(state) STMT_START { \
1306 U16 dupe= trie->states[ state ].wordnum; \
1307 regnode * const noper_next = regnext( noper ); \
1310 /* store the word for dumping */ \
1312 if (OP(noper) != NOTHING) \
1313 tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF); \
1315 tmp = newSVpvn_utf8( "", 0, UTF ); \
1316 av_push( trie_words, tmp ); \
1320 trie->wordinfo[curword].prev = 0; \
1321 trie->wordinfo[curword].len = wordlen; \
1322 trie->wordinfo[curword].accept = state; \
1324 if ( noper_next < tail ) { \
1326 trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, sizeof(U16) ); \
1327 trie->jump[curword] = (U16)(noper_next - convert); \
1329 jumper = noper_next; \
1331 nextbranch= regnext(cur); \
1335 /* It's a dupe. Pre-insert into the wordinfo[].prev */\
1336 /* chain, so that when the bits of chain are later */\
1337 /* linked together, the dups appear in the chain */\
1338 trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
1339 trie->wordinfo[dupe].prev = curword; \
1341 /* we haven't inserted this word yet. */ \
1342 trie->states[ state ].wordnum = curword; \
1347 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special) \
1348 ( ( base + charid >= ucharcount \
1349 && base + charid < ubound \
1350 && state == trie->trans[ base - ucharcount + charid ].check \
1351 && trie->trans[ base - ucharcount + charid ].next ) \
1352 ? trie->trans[ base - ucharcount + charid ].next \
1353 : ( state==1 ? special : 0 ) \
1357 #define MADE_JUMP_TRIE 2
1358 #define MADE_EXACT_TRIE 4
1361 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
1364 /* first pass, loop through and scan words */
1365 reg_trie_data *trie;
1366 HV *widecharmap = NULL;
1367 AV *revcharmap = newAV();
1369 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1374 regnode *jumper = NULL;
1375 regnode *nextbranch = NULL;
1376 regnode *convert = NULL;
1377 U32 *prev_states; /* temp array mapping each state to previous one */
1378 /* we just use folder as a flag in utf8 */
1379 const U8 * folder = NULL;
1382 const U32 data_slot = add_data( pRExC_state, 4, "tuuu" );
1383 AV *trie_words = NULL;
1384 /* along with revcharmap, this only used during construction but both are
1385 * useful during debugging so we store them in the struct when debugging.
1388 const U32 data_slot = add_data( pRExC_state, 2, "tu" );
1389 STRLEN trie_charcount=0;
1391 SV *re_trie_maxbuff;
1392 GET_RE_DEBUG_FLAGS_DECL;
1394 PERL_ARGS_ASSERT_MAKE_TRIE;
1396 PERL_UNUSED_ARG(depth);
1400 case EXACTFU: folder = PL_fold_latin1; break;
1401 case EXACTF: folder = PL_fold; break;
1402 case EXACTFL: folder = PL_fold_locale; break;
1405 trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
1407 trie->startstate = 1;
1408 trie->wordcount = word_count;
1409 RExC_rxi->data->data[ data_slot ] = (void*)trie;
1410 trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
1411 if (!(UTF && folder))
1412 trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
1413 trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
1414 trie->wordcount+1, sizeof(reg_trie_wordinfo));
1417 trie_words = newAV();
1420 re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1421 if (!SvIOK(re_trie_maxbuff)) {
1422 sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1425 PerlIO_printf( Perl_debug_log,
1426 "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
1427 (int)depth * 2 + 2, "",
1428 REG_NODE_NUM(startbranch),REG_NODE_NUM(first),
1429 REG_NODE_NUM(last), REG_NODE_NUM(tail),
1433 /* Find the node we are going to overwrite */
1434 if ( first == startbranch && OP( last ) != BRANCH ) {
1435 /* whole branch chain */
1438 /* branch sub-chain */
1439 convert = NEXTOPER( first );
1442 /* -- First loop and Setup --
1444 We first traverse the branches and scan each word to determine if it
1445 contains widechars, and how many unique chars there are, this is
1446 important as we have to build a table with at least as many columns as we
1449 We use an array of integers to represent the character codes 0..255
1450 (trie->charmap) and we use a an HV* to store Unicode characters. We use the
1451 native representation of the character value as the key and IV's for the
1454 *TODO* If we keep track of how many times each character is used we can
1455 remap the columns so that the table compression later on is more
1456 efficient in terms of memory by ensuring the most common value is in the
1457 middle and the least common are on the outside. IMO this would be better
1458 than a most to least common mapping as theres a decent chance the most
1459 common letter will share a node with the least common, meaning the node
1460 will not be compressible. With a middle is most common approach the worst
1461 case is when we have the least common nodes twice.
1465 for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1466 regnode * const noper = NEXTOPER( cur );
1467 const U8 *uc = (U8*)STRING( noper );
1468 const U8 * const e = uc + STR_LEN( noper );
1470 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1471 const U8 *scan = (U8*)NULL;
1472 U32 wordlen = 0; /* required init */
1474 bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the bitmap?*/
1476 if (OP(noper) == NOTHING) {
1480 if ( set_bit ) /* bitmap only alloced when !(UTF&&Folding) */
1481 TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
1482 regardless of encoding */
1484 for ( ; uc < e ; uc += len ) {
1485 TRIE_CHARCOUNT(trie)++;
1489 if ( !trie->charmap[ uvc ] ) {
1490 trie->charmap[ uvc ]=( ++trie->uniquecharcount );
1492 trie->charmap[ folder[ uvc ] ] = trie->charmap[ uvc ];
1496 /* store the codepoint in the bitmap, and its folded
1498 TRIE_BITMAP_SET(trie,uvc);
1500 /* store the folded codepoint */
1501 if ( folder ) TRIE_BITMAP_SET(trie,folder[ uvc ]);
1504 /* store first byte of utf8 representation of
1505 variant codepoints */
1506 if (! UNI_IS_INVARIANT(uvc)) {
1507 TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
1510 set_bit = 0; /* We've done our bit :-) */
1515 widecharmap = newHV();
1517 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
1520 Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
1522 if ( !SvTRUE( *svpp ) ) {
1523 sv_setiv( *svpp, ++trie->uniquecharcount );
1528 if( cur == first ) {
1531 } else if (chars < trie->minlen) {
1533 } else if (chars > trie->maxlen) {
1537 } /* end first pass */
1538 DEBUG_TRIE_COMPILE_r(
1539 PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
1540 (int)depth * 2 + 2,"",
1541 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
1542 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
1543 (int)trie->minlen, (int)trie->maxlen )
1547 We now know what we are dealing with in terms of unique chars and
1548 string sizes so we can calculate how much memory a naive
1549 representation using a flat table will take. If it's over a reasonable
1550 limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
1551 conservative but potentially much slower representation using an array
1554 At the end we convert both representations into the same compressed
1555 form that will be used in regexec.c for matching with. The latter
1556 is a form that cannot be used to construct with but has memory
1557 properties similar to the list form and access properties similar
1558 to the table form making it both suitable for fast searches and
1559 small enough that its feasable to store for the duration of a program.
1561 See the comment in the code where the compressed table is produced
1562 inplace from the flat tabe representation for an explanation of how
1563 the compression works.
1568 Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
1571 if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
1573 Second Pass -- Array Of Lists Representation
1575 Each state will be represented by a list of charid:state records
1576 (reg_trie_trans_le) the first such element holds the CUR and LEN
1577 points of the allocated array. (See defines above).
1579 We build the initial structure using the lists, and then convert
1580 it into the compressed table form which allows faster lookups
1581 (but cant be modified once converted).
1584 STRLEN transcount = 1;
1586 DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
1587 "%*sCompiling trie using list compiler\n",
1588 (int)depth * 2 + 2, ""));
1590 trie->states = (reg_trie_state *)
1591 PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1592 sizeof(reg_trie_state) );
1596 for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1598 regnode * const noper = NEXTOPER( cur );
1599 U8 *uc = (U8*)STRING( noper );
1600 const U8 * const e = uc + STR_LEN( noper );
1601 U32 state = 1; /* required init */
1602 U16 charid = 0; /* sanity init */
1603 U8 *scan = (U8*)NULL; /* sanity init */
1604 STRLEN foldlen = 0; /* required init */
1605 U32 wordlen = 0; /* required init */
1606 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1608 if (OP(noper) != NOTHING) {
1609 for ( ; uc < e ; uc += len ) {
1614 charid = trie->charmap[ uvc ];
1616 SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1620 charid=(U16)SvIV( *svpp );
1623 /* charid is now 0 if we dont know the char read, or nonzero if we do */
1630 if ( !trie->states[ state ].trans.list ) {
1631 TRIE_LIST_NEW( state );
1633 for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
1634 if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
1635 newstate = TRIE_LIST_ITEM( state, check ).newstate;
1640 newstate = next_alloc++;
1641 prev_states[newstate] = state;
1642 TRIE_LIST_PUSH( state, charid, newstate );
1647 Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1651 TRIE_HANDLE_WORD(state);
1653 } /* end second pass */
1655 /* next alloc is the NEXT state to be allocated */
1656 trie->statecount = next_alloc;
1657 trie->states = (reg_trie_state *)
1658 PerlMemShared_realloc( trie->states,
1660 * sizeof(reg_trie_state) );
1662 /* and now dump it out before we compress it */
1663 DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
1664 revcharmap, next_alloc,
1668 trie->trans = (reg_trie_trans *)
1669 PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
1676 for( state=1 ; state < next_alloc ; state ++ ) {
1680 DEBUG_TRIE_COMPILE_MORE_r(
1681 PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1685 if (trie->states[state].trans.list) {
1686 U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1690 for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1691 const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1692 if ( forid < minid ) {
1694 } else if ( forid > maxid ) {
1698 if ( transcount < tp + maxid - minid + 1) {
1700 trie->trans = (reg_trie_trans *)
1701 PerlMemShared_realloc( trie->trans,
1703 * sizeof(reg_trie_trans) );
1704 Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1706 base = trie->uniquecharcount + tp - minid;
1707 if ( maxid == minid ) {
1709 for ( ; zp < tp ; zp++ ) {
1710 if ( ! trie->trans[ zp ].next ) {
1711 base = trie->uniquecharcount + zp - minid;
1712 trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1713 trie->trans[ zp ].check = state;
1719 trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1720 trie->trans[ tp ].check = state;
1725 for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1726 const U32 tid = base - trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1727 trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1728 trie->trans[ tid ].check = state;
1730 tp += ( maxid - minid + 1 );
1732 Safefree(trie->states[ state ].trans.list);
1735 DEBUG_TRIE_COMPILE_MORE_r(
1736 PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1739 trie->states[ state ].trans.base=base;
1741 trie->lasttrans = tp + 1;
1745 Second Pass -- Flat Table Representation.
1747 we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1748 We know that we will need Charcount+1 trans at most to store the data
1749 (one row per char at worst case) So we preallocate both structures
1750 assuming worst case.
1752 We then construct the trie using only the .next slots of the entry
1755 We use the .check field of the first entry of the node temporarily to
1756 make compression both faster and easier by keeping track of how many non
1757 zero fields are in the node.
1759 Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1762 There are two terms at use here: state as a TRIE_NODEIDX() which is a
1763 number representing the first entry of the node, and state as a
1764 TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1765 TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1766 are 2 entrys per node. eg:
1774 The table is internally in the right hand, idx form. However as we also
1775 have to deal with the states array which is indexed by nodenum we have to
1776 use TRIE_NODENUM() to convert.
1779 DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
1780 "%*sCompiling trie using table compiler\n",
1781 (int)depth * 2 + 2, ""));
1783 trie->trans = (reg_trie_trans *)
1784 PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
1785 * trie->uniquecharcount + 1,
1786 sizeof(reg_trie_trans) );
1787 trie->states = (reg_trie_state *)
1788 PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1789 sizeof(reg_trie_state) );
1790 next_alloc = trie->uniquecharcount + 1;
1793 for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1795 regnode * const noper = NEXTOPER( cur );
1796 const U8 *uc = (U8*)STRING( noper );
1797 const U8 * const e = uc + STR_LEN( noper );
1799 U32 state = 1; /* required init */
1801 U16 charid = 0; /* sanity init */
1802 U32 accept_state = 0; /* sanity init */
1803 U8 *scan = (U8*)NULL; /* sanity init */
1805 STRLEN foldlen = 0; /* required init */
1806 U32 wordlen = 0; /* required init */
1807 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1809 if ( OP(noper) != NOTHING ) {
1810 for ( ; uc < e ; uc += len ) {
1815 charid = trie->charmap[ uvc ];
1817 SV* const * const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1818 charid = svpp ? (U16)SvIV(*svpp) : 0;
1822 if ( !trie->trans[ state + charid ].next ) {
1823 trie->trans[ state + charid ].next = next_alloc;
1824 trie->trans[ state ].check++;
1825 prev_states[TRIE_NODENUM(next_alloc)]
1826 = TRIE_NODENUM(state);
1827 next_alloc += trie->uniquecharcount;
1829 state = trie->trans[ state + charid ].next;
1831 Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1833 /* charid is now 0 if we dont know the char read, or nonzero if we do */
1836 accept_state = TRIE_NODENUM( state );
1837 TRIE_HANDLE_WORD(accept_state);
1839 } /* end second pass */
1841 /* and now dump it out before we compress it */
1842 DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
1844 next_alloc, depth+1));
1848 * Inplace compress the table.*
1850 For sparse data sets the table constructed by the trie algorithm will
1851 be mostly 0/FAIL transitions or to put it another way mostly empty.
1852 (Note that leaf nodes will not contain any transitions.)
1854 This algorithm compresses the tables by eliminating most such
1855 transitions, at the cost of a modest bit of extra work during lookup:
1857 - Each states[] entry contains a .base field which indicates the
1858 index in the state[] array wheres its transition data is stored.
1860 - If .base is 0 there are no valid transitions from that node.
1862 - If .base is nonzero then charid is added to it to find an entry in
1865 -If trans[states[state].base+charid].check!=state then the
1866 transition is taken to be a 0/Fail transition. Thus if there are fail
1867 transitions at the front of the node then the .base offset will point
1868 somewhere inside the previous nodes data (or maybe even into a node
1869 even earlier), but the .check field determines if the transition is
1873 The following process inplace converts the table to the compressed
1874 table: We first do not compress the root node 1,and mark all its
1875 .check pointers as 1 and set its .base pointer as 1 as well. This
1876 allows us to do a DFA construction from the compressed table later,
1877 and ensures that any .base pointers we calculate later are greater
1880 - We set 'pos' to indicate the first entry of the second node.
1882 - We then iterate over the columns of the node, finding the first and
1883 last used entry at l and m. We then copy l..m into pos..(pos+m-l),
1884 and set the .check pointers accordingly, and advance pos
1885 appropriately and repreat for the next node. Note that when we copy
1886 the next pointers we have to convert them from the original
1887 NODEIDX form to NODENUM form as the former is not valid post
1890 - If a node has no transitions used we mark its base as 0 and do not
1891 advance the pos pointer.
1893 - If a node only has one transition we use a second pointer into the
1894 structure to fill in allocated fail transitions from other states.
1895 This pointer is independent of the main pointer and scans forward
1896 looking for null transitions that are allocated to a state. When it
1897 finds one it writes the single transition into the "hole". If the
1898 pointer doesnt find one the single transition is appended as normal.
1900 - Once compressed we can Renew/realloc the structures to release the
1903 See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
1904 specifically Fig 3.47 and the associated pseudocode.
1908 const U32 laststate = TRIE_NODENUM( next_alloc );
1911 trie->statecount = laststate;
1913 for ( state = 1 ; state < laststate ; state++ ) {
1915 const U32 stateidx = TRIE_NODEIDX( state );
1916 const U32 o_used = trie->trans[ stateidx ].check;
1917 U32 used = trie->trans[ stateidx ].check;
1918 trie->trans[ stateidx ].check = 0;
1920 for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
1921 if ( flag || trie->trans[ stateidx + charid ].next ) {
1922 if ( trie->trans[ stateidx + charid ].next ) {
1924 for ( ; zp < pos ; zp++ ) {
1925 if ( ! trie->trans[ zp ].next ) {
1929 trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
1930 trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
1931 trie->trans[ zp ].check = state;
1932 if ( ++zp > pos ) pos = zp;
1939 trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
1941 trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
1942 trie->trans[ pos ].check = state;
1947 trie->lasttrans = pos + 1;
1948 trie->states = (reg_trie_state *)
1949 PerlMemShared_realloc( trie->states, laststate
1950 * sizeof(reg_trie_state) );
1951 DEBUG_TRIE_COMPILE_MORE_r(
1952 PerlIO_printf( Perl_debug_log,
1953 "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
1954 (int)depth * 2 + 2,"",
1955 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ),
1958 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
1961 } /* end table compress */
1963 DEBUG_TRIE_COMPILE_MORE_r(
1964 PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
1965 (int)depth * 2 + 2, "",
1966 (UV)trie->statecount,
1967 (UV)trie->lasttrans)
1969 /* resize the trans array to remove unused space */
1970 trie->trans = (reg_trie_trans *)
1971 PerlMemShared_realloc( trie->trans, trie->lasttrans
1972 * sizeof(reg_trie_trans) );
1974 { /* Modify the program and insert the new TRIE node */
1975 U8 nodetype =(U8)(flags & 0xFF);
1979 regnode *optimize = NULL;
1980 #ifdef RE_TRACK_PATTERN_OFFSETS
1983 U32 mjd_nodelen = 0;
1984 #endif /* RE_TRACK_PATTERN_OFFSETS */
1985 #endif /* DEBUGGING */
1987 This means we convert either the first branch or the first Exact,
1988 depending on whether the thing following (in 'last') is a branch
1989 or not and whther first is the startbranch (ie is it a sub part of
1990 the alternation or is it the whole thing.)
1991 Assuming its a sub part we convert the EXACT otherwise we convert
1992 the whole branch sequence, including the first.
1994 /* Find the node we are going to overwrite */
1995 if ( first != startbranch || OP( last ) == BRANCH ) {
1996 /* branch sub-chain */
1997 NEXT_OFF( first ) = (U16)(last - first);
1998 #ifdef RE_TRACK_PATTERN_OFFSETS
2000 mjd_offset= Node_Offset((convert));
2001 mjd_nodelen= Node_Length((convert));
2004 /* whole branch chain */
2006 #ifdef RE_TRACK_PATTERN_OFFSETS
2009 const regnode *nop = NEXTOPER( convert );
2010 mjd_offset= Node_Offset((nop));
2011 mjd_nodelen= Node_Length((nop));
2015 PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
2016 (int)depth * 2 + 2, "",
2017 (UV)mjd_offset, (UV)mjd_nodelen)
2020 /* But first we check to see if there is a common prefix we can
2021 split out as an EXACT and put in front of the TRIE node. */
2022 trie->startstate= 1;
2023 if ( trie->bitmap && !widecharmap && !trie->jump ) {
2025 for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
2029 const U32 base = trie->states[ state ].trans.base;
2031 if ( trie->states[state].wordnum )
2034 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2035 if ( ( base + ofs >= trie->uniquecharcount ) &&
2036 ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
2037 trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
2039 if ( ++count > 1 ) {
2040 SV **tmp = av_fetch( revcharmap, ofs, 0);
2041 const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
2042 if ( state == 1 ) break;
2044 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
2046 PerlIO_printf(Perl_debug_log,
2047 "%*sNew Start State=%"UVuf" Class: [",
2048 (int)depth * 2 + 2, "",
2051 SV ** const tmp = av_fetch( revcharmap, idx, 0);
2052 const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
2054 TRIE_BITMAP_SET(trie,*ch);
2056 TRIE_BITMAP_SET(trie, folder[ *ch ]);
2058 PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
2062 TRIE_BITMAP_SET(trie,*ch);
2064 TRIE_BITMAP_SET(trie,folder[ *ch ]);
2065 DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
2071 SV **tmp = av_fetch( revcharmap, idx, 0);
2073 char *ch = SvPV( *tmp, len );
2075 SV *sv=sv_newmortal();
2076 PerlIO_printf( Perl_debug_log,
2077 "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
2078 (int)depth * 2 + 2, "",
2080 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
2081 PL_colors[0], PL_colors[1],
2082 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2083 PERL_PV_ESCAPE_FIRSTCHAR
2088 OP( convert ) = nodetype;
2089 str=STRING(convert);
2092 STR_LEN(convert) += len;
2098 DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
2103 trie->prefixlen = (state-1);
2105 regnode *n = convert+NODE_SZ_STR(convert);
2106 NEXT_OFF(convert) = NODE_SZ_STR(convert);
2107 trie->startstate = state;
2108 trie->minlen -= (state - 1);
2109 trie->maxlen -= (state - 1);
2111 /* At least the UNICOS C compiler choked on this
2112 * being argument to DEBUG_r(), so let's just have
2115 #ifdef PERL_EXT_RE_BUILD
2121 regnode *fix = convert;
2122 U32 word = trie->wordcount;
2124 Set_Node_Offset_Length(convert, mjd_offset, state - 1);
2125 while( ++fix < n ) {
2126 Set_Node_Offset_Length(fix, 0, 0);
2129 SV ** const tmp = av_fetch( trie_words, word, 0 );
2131 if ( STR_LEN(convert) <= SvCUR(*tmp) )
2132 sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
2134 sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
2142 NEXT_OFF(convert) = (U16)(tail - convert);
2143 DEBUG_r(optimize= n);
2149 if ( trie->maxlen ) {
2150 NEXT_OFF( convert ) = (U16)(tail - convert);
2151 ARG_SET( convert, data_slot );
2152 /* Store the offset to the first unabsorbed branch in
2153 jump[0], which is otherwise unused by the jump logic.
2154 We use this when dumping a trie and during optimisation. */
2156 trie->jump[0] = (U16)(nextbranch - convert);
2158 /* If the start state is not accepting (meaning there is no empty string/NOTHING)
2159 * and there is a bitmap
2160 * and the first "jump target" node we found leaves enough room
2161 * then convert the TRIE node into a TRIEC node, with the bitmap
2162 * embedded inline in the opcode - this is hypothetically faster.
2164 if ( !trie->states[trie->startstate].wordnum
2166 && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
2168 OP( convert ) = TRIEC;
2169 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
2170 PerlMemShared_free(trie->bitmap);
2173 OP( convert ) = TRIE;
2175 /* store the type in the flags */
2176 convert->flags = nodetype;
2180 + regarglen[ OP( convert ) ];
2182 /* XXX We really should free up the resource in trie now,
2183 as we won't use them - (which resources?) dmq */
2185 /* needed for dumping*/
2186 DEBUG_r(if (optimize) {
2187 regnode *opt = convert;
2189 while ( ++opt < optimize) {
2190 Set_Node_Offset_Length(opt,0,0);
2193 Try to clean up some of the debris left after the
2196 while( optimize < jumper ) {
2197 mjd_nodelen += Node_Length((optimize));
2198 OP( optimize ) = OPTIMIZED;
2199 Set_Node_Offset_Length(optimize,0,0);
2202 Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2204 } /* end node insert */
2206 /* Finish populating the prev field of the wordinfo array. Walk back
2207 * from each accept state until we find another accept state, and if
2208 * so, point the first word's .prev field at the second word. If the
2209 * second already has a .prev field set, stop now. This will be the
2210 * case either if we've already processed that word's accept state,
2211 * or that state had multiple words, and the overspill words were
2212 * already linked up earlier.
2219 for (word=1; word <= trie->wordcount; word++) {
2221 if (trie->wordinfo[word].prev)
2223 state = trie->wordinfo[word].accept;
2225 state = prev_states[state];
2228 prev = trie->states[state].wordnum;
2232 trie->wordinfo[word].prev = prev;
2234 Safefree(prev_states);
2238 /* and now dump out the compressed format */
2239 DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
2241 RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2243 RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2244 RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2246 SvREFCNT_dec(revcharmap);
2250 : trie->startstate>1
2256 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source, regnode *stclass, U32 depth)
2258 /* The Trie is constructed and compressed now so we can build a fail array if it's needed
2260 This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
2261 "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
2264 We find the fail state for each state in the trie, this state is the longest proper
2265 suffix of the current state's 'word' that is also a proper prefix of another word in our
2266 trie. State 1 represents the word '' and is thus the default fail state. This allows
2267 the DFA not to have to restart after its tried and failed a word at a given point, it
2268 simply continues as though it had been matching the other word in the first place.
2270 'abcdgu'=~/abcdefg|cdgu/
2271 When we get to 'd' we are still matching the first word, we would encounter 'g' which would
2272 fail, which would bring us to the state representing 'd' in the second word where we would
2273 try 'g' and succeed, proceeding to match 'cdgu'.
2275 /* add a fail transition */
2276 const U32 trie_offset = ARG(source);
2277 reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
2279 const U32 ucharcount = trie->uniquecharcount;
2280 const U32 numstates = trie->statecount;
2281 const U32 ubound = trie->lasttrans + ucharcount;
2285 U32 base = trie->states[ 1 ].trans.base;
2288 const U32 data_slot = add_data( pRExC_state, 1, "T" );
2289 GET_RE_DEBUG_FLAGS_DECL;
2291 PERL_ARGS_ASSERT_MAKE_TRIE_FAILTABLE;
2293 PERL_UNUSED_ARG(depth);
2297 ARG_SET( stclass, data_slot );
2298 aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
2299 RExC_rxi->data->data[ data_slot ] = (void*)aho;
2300 aho->trie=trie_offset;
2301 aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
2302 Copy( trie->states, aho->states, numstates, reg_trie_state );
2303 Newxz( q, numstates, U32);
2304 aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
2307 /* initialize fail[0..1] to be 1 so that we always have
2308 a valid final fail state */
2309 fail[ 0 ] = fail[ 1 ] = 1;
2311 for ( charid = 0; charid < ucharcount ; charid++ ) {
2312 const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2314 q[ q_write ] = newstate;
2315 /* set to point at the root */
2316 fail[ q[ q_write++ ] ]=1;
2319 while ( q_read < q_write) {
2320 const U32 cur = q[ q_read++ % numstates ];
2321 base = trie->states[ cur ].trans.base;
2323 for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2324 const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2326 U32 fail_state = cur;
2329 fail_state = fail[ fail_state ];
2330 fail_base = aho->states[ fail_state ].trans.base;
2331 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2333 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2334 fail[ ch_state ] = fail_state;
2335 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2337 aho->states[ ch_state ].wordnum = aho->states[ fail_state ].wordnum;
2339 q[ q_write++ % numstates] = ch_state;
2343 /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2344 when we fail in state 1, this allows us to use the
2345 charclass scan to find a valid start char. This is based on the principle
2346 that theres a good chance the string being searched contains lots of stuff
2347 that cant be a start char.
2349 fail[ 0 ] = fail[ 1 ] = 0;
2350 DEBUG_TRIE_COMPILE_r({
2351 PerlIO_printf(Perl_debug_log,
2352 "%*sStclass Failtable (%"UVuf" states): 0",
2353 (int)(depth * 2), "", (UV)numstates
2355 for( q_read=1; q_read<numstates; q_read++ ) {
2356 PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2358 PerlIO_printf(Perl_debug_log, "\n");
2361 /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2366 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2367 * These need to be revisited when a newer toolchain becomes available.
2369 #if defined(__sparc64__) && defined(__GNUC__)
2370 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2371 # undef SPARC64_GCC_WORKAROUND
2372 # define SPARC64_GCC_WORKAROUND 1
2376 #define DEBUG_PEEP(str,scan,depth) \
2377 DEBUG_OPTIMISE_r({if (scan){ \
2378 SV * const mysv=sv_newmortal(); \
2379 regnode *Next = regnext(scan); \
2380 regprop(RExC_rx, mysv, scan); \
2381 PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
2382 (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2383 Next ? (REG_NODE_NUM(Next)) : 0 ); \
2390 #define JOIN_EXACT(scan,min,flags) \
2391 if (PL_regkind[OP(scan)] == EXACT) \
2392 join_exact(pRExC_state,(scan),(min),(flags),NULL,depth+1)
2395 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags,regnode *val, U32 depth) {
2396 /* Merge several consecutive EXACTish nodes into one. */
2397 regnode *n = regnext(scan);
2399 regnode *next = scan + NODE_SZ_STR(scan);
2403 regnode *stop = scan;
2404 GET_RE_DEBUG_FLAGS_DECL;
2406 PERL_UNUSED_ARG(depth);
2409 PERL_ARGS_ASSERT_JOIN_EXACT;
2410 #ifndef EXPERIMENTAL_INPLACESCAN
2411 PERL_UNUSED_ARG(flags);
2412 PERL_UNUSED_ARG(val);
2414 DEBUG_PEEP("join",scan,depth);
2416 /* Skip NOTHING, merge EXACT*. */
2418 ( PL_regkind[OP(n)] == NOTHING ||
2419 (stringok && (OP(n) == OP(scan))))
2421 && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
2423 if (OP(n) == TAIL || n > next)
2425 if (PL_regkind[OP(n)] == NOTHING) {
2426 DEBUG_PEEP("skip:",n,depth);
2427 NEXT_OFF(scan) += NEXT_OFF(n);
2428 next = n + NODE_STEP_REGNODE;
2435 else if (stringok) {
2436 const unsigned int oldl = STR_LEN(scan);
2437 regnode * const nnext = regnext(n);
2439 DEBUG_PEEP("merg",n,depth);
2442 if (oldl + STR_LEN(n) > U8_MAX)
2444 NEXT_OFF(scan) += NEXT_OFF(n);
2445 STR_LEN(scan) += STR_LEN(n);
2446 next = n + NODE_SZ_STR(n);
2447 /* Now we can overwrite *n : */
2448 Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2456 #ifdef EXPERIMENTAL_INPLACESCAN
2457 if (flags && !NEXT_OFF(n)) {
2458 DEBUG_PEEP("atch", val, depth);
2459 if (reg_off_by_arg[OP(n)]) {
2460 ARG_SET(n, val - n);
2463 NEXT_OFF(n) = val - n;
2469 #define GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS 0x0390
2470 #define IOTA_D_T GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS
2471 #define GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS 0x03B0
2472 #define UPSILON_D_T GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS
2475 && ( OP(scan) == EXACTF || OP(scan) == EXACTFU)
2476 && ( STR_LEN(scan) >= 6 ) )
2479 Two problematic code points in Unicode casefolding of EXACT nodes:
2481 U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
2482 U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
2488 U+03B9 U+0308 U+0301 0xCE 0xB9 0xCC 0x88 0xCC 0x81
2489 U+03C5 U+0308 U+0301 0xCF 0x85 0xCC 0x88 0xCC 0x81
2491 This means that in case-insensitive matching (or "loose matching",
2492 as Unicode calls it), an EXACTF of length six (the UTF-8 encoded byte
2493 length of the above casefolded versions) can match a target string
2494 of length two (the byte length of UTF-8 encoded U+0390 or U+03B0).
2495 This would rather mess up the minimum length computation.
2497 What we'll do is to look for the tail four bytes, and then peek
2498 at the preceding two bytes to see whether we need to decrease
2499 the minimum length by four (six minus two).
2501 Thanks to the design of UTF-8, there cannot be false matches:
2502 A sequence of valid UTF-8 bytes cannot be a subsequence of
2503 another valid sequence of UTF-8 bytes.
2506 char * const s0 = STRING(scan), *s, *t;
2507 char * const s1 = s0 + STR_LEN(scan) - 1;
2508 char * const s2 = s1 - 4;
2509 #ifdef EBCDIC /* RD tunifold greek 0390 and 03B0 */
2510 const char t0[] = "\xaf\x49\xaf\x42";
2512 const char t0[] = "\xcc\x88\xcc\x81";
2514 const char * const t1 = t0 + 3;
2517 s < s2 && (t = ninstr(s, s1, t0, t1));
2520 if (((U8)t[-1] == 0x68 && (U8)t[-2] == 0xB4) ||
2521 ((U8)t[-1] == 0x46 && (U8)t[-2] == 0xB5))
2523 if (((U8)t[-1] == 0xB9 && (U8)t[-2] == 0xCE) ||
2524 ((U8)t[-1] == 0x85 && (U8)t[-2] == 0xCF))
2532 n = scan + NODE_SZ_STR(scan);
2534 if (PL_regkind[OP(n)] != NOTHING || OP(n) == NOTHING) {
2541 DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2545 /* REx optimizer. Converts nodes into quicker variants "in place".
2546 Finds fixed substrings. */
2548 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
2549 to the position after last scanned or to NULL. */
2551 #define INIT_AND_WITHP \
2552 assert(!and_withp); \
2553 Newx(and_withp,1,struct regnode_charclass_class); \
2554 SAVEFREEPV(and_withp)
2556 /* this is a chain of data about sub patterns we are processing that
2557 need to be handled separately/specially in study_chunk. Its so
2558 we can simulate recursion without losing state. */
2560 typedef struct scan_frame {
2561 regnode *last; /* last node to process in this frame */
2562 regnode *next; /* next node to process when last is reached */
2563 struct scan_frame *prev; /*previous frame*/
2564 I32 stop; /* what stopparen do we use */
2568 #define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
2570 #define CASE_SYNST_FNC(nAmE) \
2572 if (flags & SCF_DO_STCLASS_AND) { \
2573 for (value = 0; value < 256; value++) \
2574 if (!is_ ## nAmE ## _cp(value)) \
2575 ANYOF_BITMAP_CLEAR(data->start_class, value); \
2578 for (value = 0; value < 256; value++) \
2579 if (is_ ## nAmE ## _cp(value)) \
2580 ANYOF_BITMAP_SET(data->start_class, value); \
2584 if (flags & SCF_DO_STCLASS_AND) { \
2585 for (value = 0; value < 256; value++) \
2586 if (is_ ## nAmE ## _cp(value)) \
2587 ANYOF_BITMAP_CLEAR(data->start_class, value); \
2590 for (value = 0; value < 256; value++) \
2591 if (!is_ ## nAmE ## _cp(value)) \
2592 ANYOF_BITMAP_SET(data->start_class, value); \
2599 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
2600 I32 *minlenp, I32 *deltap,
2605 struct regnode_charclass_class *and_withp,
2606 U32 flags, U32 depth)
2607 /* scanp: Start here (read-write). */
2608 /* deltap: Write maxlen-minlen here. */
2609 /* last: Stop before this one. */
2610 /* data: string data about the pattern */
2611 /* stopparen: treat close N as END */
2612 /* recursed: which subroutines have we recursed into */
2613 /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
2616 I32 min = 0, pars = 0, code;
2617 regnode *scan = *scanp, *next;
2619 int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
2620 int is_inf_internal = 0; /* The studied chunk is infinite */
2621 I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
2622 scan_data_t data_fake;
2623 SV *re_trie_maxbuff = NULL;
2624 regnode *first_non_open = scan;
2625 I32 stopmin = I32_MAX;
2626 scan_frame *frame = NULL;
2627 GET_RE_DEBUG_FLAGS_DECL;
2629 PERL_ARGS_ASSERT_STUDY_CHUNK;
2632 StructCopy(&zero_scan_data, &data_fake, scan_data_t);
2636 while (first_non_open && OP(first_non_open) == OPEN)
2637 first_non_open=regnext(first_non_open);
2642 while ( scan && OP(scan) != END && scan < last ){
2643 /* Peephole optimizer: */
2644 DEBUG_STUDYDATA("Peep:", data,depth);
2645 DEBUG_PEEP("Peep",scan,depth);
2646 JOIN_EXACT(scan,&min,0);
2648 /* Follow the next-chain of the current node and optimize
2649 away all the NOTHINGs from it. */
2650 if (OP(scan) != CURLYX) {
2651 const int max = (reg_off_by_arg[OP(scan)]
2653 /* I32 may be smaller than U16 on CRAYs! */
2654 : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
2655 int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
2659 /* Skip NOTHING and LONGJMP. */
2660 while ((n = regnext(n))
2661 && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
2662 || ((OP(n) == LONGJMP) && (noff = ARG(n))))
2663 && off + noff < max)
2665 if (reg_off_by_arg[OP(scan)])
2668 NEXT_OFF(scan) = off;
2673 /* The principal pseudo-switch. Cannot be a switch, since we
2674 look into several different things. */
2675 if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
2676 || OP(scan) == IFTHEN) {
2677 next = regnext(scan);
2679 /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
2681 if (OP(next) == code || code == IFTHEN) {
2682 /* NOTE - There is similar code to this block below for handling
2683 TRIE nodes on a re-study. If you change stuff here check there
2685 I32 max1 = 0, min1 = I32_MAX, num = 0;
2686 struct regnode_charclass_class accum;
2687 regnode * const startbranch=scan;
2689 if (flags & SCF_DO_SUBSTR)
2690 SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
2691 if (flags & SCF_DO_STCLASS)
2692 cl_init_zero(pRExC_state, &accum);
2694 while (OP(scan) == code) {
2695 I32 deltanext, minnext, f = 0, fake;
2696 struct regnode_charclass_class this_class;
2699 data_fake.flags = 0;
2701 data_fake.whilem_c = data->whilem_c;
2702 data_fake.last_closep = data->last_closep;
2705 data_fake.last_closep = &fake;
2707 data_fake.pos_delta = delta;
2708 next = regnext(scan);
2709 scan = NEXTOPER(scan);
2711 scan = NEXTOPER(scan);
2712 if (flags & SCF_DO_STCLASS) {
2713 cl_init(pRExC_state, &this_class);
2714 data_fake.start_class = &this_class;
2715 f = SCF_DO_STCLASS_AND;
2717 if (flags & SCF_WHILEM_VISITED_POS)
2718 f |= SCF_WHILEM_VISITED_POS;
2720 /* we suppose the run is continuous, last=next...*/
2721 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
2723 stopparen, recursed, NULL, f,depth+1);
2726 if (max1 < minnext + deltanext)
2727 max1 = minnext + deltanext;
2728 if (deltanext == I32_MAX)
2729 is_inf = is_inf_internal = 1;
2731 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
2733 if (data_fake.flags & SCF_SEEN_ACCEPT) {
2734 if ( stopmin > minnext)
2735 stopmin = min + min1;
2736 flags &= ~SCF_DO_SUBSTR;
2738 data->flags |= SCF_SEEN_ACCEPT;
2741 if (data_fake.flags & SF_HAS_EVAL)
2742 data->flags |= SF_HAS_EVAL;
2743 data->whilem_c = data_fake.whilem_c;
2745 if (flags & SCF_DO_STCLASS)
2746 cl_or(pRExC_state, &accum, &this_class);
2748 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
2750 if (flags & SCF_DO_SUBSTR) {
2751 data->pos_min += min1;
2752 data->pos_delta += max1 - min1;
2753 if (max1 != min1 || is_inf)
2754 data->longest = &(data->longest_float);
2757 delta += max1 - min1;
2758 if (flags & SCF_DO_STCLASS_OR) {
2759 cl_or(pRExC_state, data->start_class, &accum);
2761 cl_and(data->start_class, and_withp);
2762 flags &= ~SCF_DO_STCLASS;
2765 else if (flags & SCF_DO_STCLASS_AND) {
2767 cl_and(data->start_class, &accum);
2768 flags &= ~SCF_DO_STCLASS;
2771 /* Switch to OR mode: cache the old value of
2772 * data->start_class */
2774 StructCopy(data->start_class, and_withp,
2775 struct regnode_charclass_class);
2776 flags &= ~SCF_DO_STCLASS_AND;
2777 StructCopy(&accum, data->start_class,
2778 struct regnode_charclass_class);
2779 flags |= SCF_DO_STCLASS_OR;
2780 data->start_class->flags |= ANYOF_EOS;
2784 if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
2787 Assuming this was/is a branch we are dealing with: 'scan' now
2788 points at the item that follows the branch sequence, whatever
2789 it is. We now start at the beginning of the sequence and look
2796 which would be constructed from a pattern like /A|LIST|OF|WORDS/
2798 If we can find such a subsequence we need to turn the first
2799 element into a trie and then add the subsequent branch exact
2800 strings to the trie.
2804 1. patterns where the whole set of branches can be converted.
2806 2. patterns where only a subset can be converted.
2808 In case 1 we can replace the whole set with a single regop
2809 for the trie. In case 2 we need to keep the start and end
2812 'BRANCH EXACT; BRANCH EXACT; BRANCH X'
2813 becomes BRANCH TRIE; BRANCH X;
2815 There is an additional case, that being where there is a
2816 common prefix, which gets split out into an EXACT like node
2817 preceding the TRIE node.
2819 If x(1..n)==tail then we can do a simple trie, if not we make
2820 a "jump" trie, such that when we match the appropriate word
2821 we "jump" to the appropriate tail node. Essentially we turn
2822 a nested if into a case structure of sorts.
2827 if (!re_trie_maxbuff) {
2828 re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2829 if (!SvIOK(re_trie_maxbuff))
2830 sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2832 if ( SvIV(re_trie_maxbuff)>=0 ) {
2834 regnode *first = (regnode *)NULL;
2835 regnode *last = (regnode *)NULL;
2836 regnode *tail = scan;
2841 SV * const mysv = sv_newmortal(); /* for dumping */
2843 /* var tail is used because there may be a TAIL
2844 regop in the way. Ie, the exacts will point to the
2845 thing following the TAIL, but the last branch will
2846 point at the TAIL. So we advance tail. If we
2847 have nested (?:) we may have to move through several
2851 while ( OP( tail ) == TAIL ) {
2852 /* this is the TAIL generated by (?:) */
2853 tail = regnext( tail );
2858 regprop(RExC_rx, mysv, tail );
2859 PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
2860 (int)depth * 2 + 2, "",
2861 "Looking for TRIE'able sequences. Tail node is: ",
2862 SvPV_nolen_const( mysv )
2868 step through the branches, cur represents each
2869 branch, noper is the first thing to be matched
2870 as part of that branch and noper_next is the
2871 regnext() of that node. if noper is an EXACT
2872 and noper_next is the same as scan (our current
2873 position in the regex) then the EXACT branch is
2874 a possible optimization target. Once we have
2875 two or more consecutive such branches we can
2876 create a trie of the EXACT's contents and stich
2877 it in place. If the sequence represents all of
2878 the branches we eliminate the whole thing and
2879 replace it with a single TRIE. If it is a
2880 subsequence then we need to stitch it in. This
2881 means the first branch has to remain, and needs
2882 to be repointed at the item on the branch chain
2883 following the last branch optimized. This could
2884 be either a BRANCH, in which case the
2885 subsequence is internal, or it could be the
2886 item following the branch sequence in which
2887 case the subsequence is at the end.
2891 /* dont use tail as the end marker for this traverse */
2892 for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
2893 regnode * const noper = NEXTOPER( cur );
2894 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
2895 regnode * const noper_next = regnext( noper );
2899 regprop(RExC_rx, mysv, cur);
2900 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
2901 (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
2903 regprop(RExC_rx, mysv, noper);
2904 PerlIO_printf( Perl_debug_log, " -> %s",
2905 SvPV_nolen_const(mysv));
2908 regprop(RExC_rx, mysv, noper_next );
2909 PerlIO_printf( Perl_debug_log,"\t=> %s\t",
2910 SvPV_nolen_const(mysv));
2912 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d)\n",
2913 REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur) );
2915 if ( (((first && optype!=NOTHING) ? OP( noper ) == optype
2916 : PL_regkind[ OP( noper ) ] == EXACT )
2917 || OP(noper) == NOTHING )
2919 && noper_next == tail
2924 if ( !first || optype == NOTHING ) {
2925 if (!first) first = cur;
2926 optype = OP( noper );
2932 Currently we do not believe that the trie logic can
2933 handle case insensitive matching properly when the
2934 pattern is not unicode (thus forcing unicode semantics).
2936 If/when this is fixed the following define can be swapped
2937 in below to fully enable trie logic.
2939 #define TRIE_TYPE_IS_SAFE 1
2942 #define TRIE_TYPE_IS_SAFE (UTF || optype==EXACT)
2944 if ( last && TRIE_TYPE_IS_SAFE ) {
2945 make_trie( pRExC_state,
2946 startbranch, first, cur, tail, count,
2949 if ( PL_regkind[ OP( noper ) ] == EXACT
2951 && noper_next == tail
2956 optype = OP( noper );
2966 regprop(RExC_rx, mysv, cur);
2967 PerlIO_printf( Perl_debug_log,
2968 "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
2969 "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
2973 if ( last && TRIE_TYPE_IS_SAFE ) {
2974 made= make_trie( pRExC_state, startbranch, first, scan, tail, count, optype, depth+1 );
2975 #ifdef TRIE_STUDY_OPT
2976 if ( ((made == MADE_EXACT_TRIE &&
2977 startbranch == first)
2978 || ( first_non_open == first )) &&
2980 flags |= SCF_TRIE_RESTUDY;
2981 if ( startbranch == first
2984 RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
2994 else if ( code == BRANCHJ ) { /* single branch is optimized. */
2995 scan = NEXTOPER(NEXTOPER(scan));
2996 } else /* single branch is optimized. */
2997 scan = NEXTOPER(scan);
2999 } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
3000 scan_frame *newframe = NULL;
3005 if (OP(scan) != SUSPEND) {
3006 /* set the pointer */
3007 if (OP(scan) == GOSUB) {
3009 RExC_recurse[ARG2L(scan)] = scan;
3010 start = RExC_open_parens[paren-1];
3011 end = RExC_close_parens[paren-1];
3014 start = RExC_rxi->program + 1;
3018 Newxz(recursed, (((RExC_npar)>>3) +1), U8);
3019 SAVEFREEPV(recursed);
3021 if (!PAREN_TEST(recursed,paren+1)) {
3022 PAREN_SET(recursed,paren+1);
3023 Newx(newframe,1,scan_frame);
3025 if (flags & SCF_DO_SUBSTR) {
3026 SCAN_COMMIT(pRExC_state,data,minlenp);
3027 data->longest = &(data->longest_float);
3029 is_inf = is_inf_internal = 1;
3030 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3031 cl_anything(pRExC_state, data->start_class);
3032 flags &= ~SCF_DO_STCLASS;
3035 Newx(newframe,1,scan_frame);
3038 end = regnext(scan);
3043 SAVEFREEPV(newframe);
3044 newframe->next = regnext(scan);
3045 newframe->last = last;
3046 newframe->stop = stopparen;
3047 newframe->prev = frame;
3057 else if (OP(scan) == EXACT) {
3058 I32 l = STR_LEN(scan);
3061 const U8 * const s = (U8*)STRING(scan);
3062 l = utf8_length(s, s + l);
3063 uc = utf8_to_uvchr(s, NULL);
3065 uc = *((U8*)STRING(scan));
3068 if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
3069 /* The code below prefers earlier match for fixed
3070 offset, later match for variable offset. */
3071 if (data->last_end == -1) { /* Update the start info. */
3072 data->last_start_min = data->pos_min;
3073 data->last_start_max = is_inf
3074 ? I32_MAX : data->pos_min + data->pos_delta;
3076 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
3078 SvUTF8_on(data->last_found);
3080 SV * const sv = data->last_found;
3081 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3082 mg_find(sv, PERL_MAGIC_utf8) : NULL;
3083 if (mg && mg->mg_len >= 0)
3084 mg->mg_len += utf8_length((U8*)STRING(scan),
3085 (U8*)STRING(scan)+STR_LEN(scan));
3087 data->last_end = data->pos_min + l;
3088 data->pos_min += l; /* As in the first entry. */
3089 data->flags &= ~SF_BEFORE_EOL;
3091 if (flags & SCF_DO_STCLASS_AND) {
3092 /* Check whether it is compatible with what we know already! */
3096 /* If compatible, we or it in below. It is compatible if is
3097 * in the bitmp and either 1) its bit or its fold is set, or 2)
3098 * it's for a locale. Even if there isn't unicode semantics
3099 * here, at runtime there may be because of matching against a
3100 * utf8 string, so accept a possible false positive for
3101 * latin1-range folds */
3103 (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3104 && !ANYOF_BITMAP_TEST(data->start_class, uc)
3105 && (!(data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD)
3106 || !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3109 ANYOF_CLASS_ZERO(data->start_class);
3110 ANYOF_BITMAP_ZERO(data->start_class);
3112 ANYOF_BITMAP_SET(data->start_class, uc);
3113 data->start_class->flags &= ~ANYOF_EOS;
3115 data->start_class->flags &= ~ANYOF_UNICODE_ALL;
3117 else if (flags & SCF_DO_STCLASS_OR) {
3118 /* false positive possible if the class is case-folded */
3120 ANYOF_BITMAP_SET(data->start_class, uc);
3122 data->start_class->flags |= ANYOF_UNICODE_ALL;
3123 data->start_class->flags &= ~ANYOF_EOS;
3124 cl_and(data->start_class, and_withp);
3126 flags &= ~SCF_DO_STCLASS;
3128 else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
3129 I32 l = STR_LEN(scan);
3130 UV uc = *((U8*)STRING(scan));
3132 /* Search for fixed substrings supports EXACT only. */
3133 if (flags & SCF_DO_SUBSTR) {
3135 SCAN_COMMIT(pRExC_state, data, minlenp);
3138 const U8 * const s = (U8 *)STRING(scan);
3139 l = utf8_length(s, s + l);
3140 uc = utf8_to_uvchr(s, NULL);
3143 if (flags & SCF_DO_SUBSTR)
3145 if (flags & SCF_DO_STCLASS_AND) {
3146 /* Check whether it is compatible with what we know already! */
3149 (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3150 && !ANYOF_BITMAP_TEST(data->start_class, uc)
3151 && !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3155 ANYOF_CLASS_ZERO(data->start_class);
3156 ANYOF_BITMAP_ZERO(data->start_class);
3158 ANYOF_BITMAP_SET(data->start_class, uc);
3159 data->start_class->flags &= ~ANYOF_EOS;
3160 data->start_class->flags |= ANYOF_LOC_NONBITMAP_FOLD;
3161 if (OP(scan) == EXACTFL) {
3162 data->start_class->flags |= ANYOF_LOCALE;
3166 /* Also set the other member of the fold pair. In case
3167 * that unicode semantics is called for at runtime, use
3168 * the full latin1 fold. (Can't do this for locale,
3169 * because not known until runtime */
3170 ANYOF_BITMAP_SET(data->start_class, PL_fold_latin1[uc]);
3174 else if (flags & SCF_DO_STCLASS_OR) {
3175 if (data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD) {
3176 /* false positive possible if the class is case-folded.
3177 Assume that the locale settings are the same... */
3179 ANYOF_BITMAP_SET(data->start_class, uc);
3180 if (OP(scan) != EXACTFL) {
3182 /* And set the other member of the fold pair, but
3183 * can't do that in locale because not known until
3185 ANYOF_BITMAP_SET(data->start_class,
3186 PL_fold_latin1[uc]);
3189 data->start_class->flags &= ~ANYOF_EOS;
3191 cl_and(data->start_class, and_withp);
3193 flags &= ~SCF_DO_STCLASS;
3195 else if (REGNODE_VARIES(OP(scan))) {
3196 I32 mincount, maxcount, minnext, deltanext, fl = 0;
3197 I32 f = flags, pos_before = 0;
3198 regnode * const oscan = scan;
3199 struct regnode_charclass_class this_class;
3200 struct regnode_charclass_class *oclass = NULL;
3201 I32 next_is_eval = 0;
3203 switch (PL_regkind[OP(scan)]) {
3204 case WHILEM: /* End of (?:...)* . */
3205 scan = NEXTOPER(scan);
3208 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
3209 next = NEXTOPER(scan);
3210 if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
3212 maxcount = REG_INFTY;
3213 next = regnext(scan);
3214 scan = NEXTOPER(scan);
3218 if (flags & SCF_DO_SUBSTR)
3223 if (flags & SCF_DO_STCLASS) {
3225 maxcount = REG_INFTY;
3226 next = regnext(scan);
3227 scan = NEXTOPER(scan);
3230 is_inf = is_inf_internal = 1;
3231 scan = regnext(scan);
3232 if (flags & SCF_DO_SUBSTR) {
3233 SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
3234 data->longest = &(data->longest_float);
3236 goto optimize_curly_tail;
3238 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
3239 && (scan->flags == stopparen))
3244 mincount = ARG1(scan);
3245 maxcount = ARG2(scan);
3247 next = regnext(scan);
3248 if (OP(scan) == CURLYX) {
3249 I32 lp = (data ? *(data->last_closep) : 0);
3250 scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
3252 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3253 next_is_eval = (OP(scan) == EVAL);
3255 if (flags & SCF_DO_SUBSTR) {
3256 if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
3257 pos_before = data->pos_min;
3261 data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
3263 data->flags |= SF_IS_INF;
3265 if (flags & SCF_DO_STCLASS) {
3266 cl_init(pRExC_state, &this_class);
3267 oclass = data->start_class;
3268 data->start_class = &this_class;
3269 f |= SCF_DO_STCLASS_AND;
3270 f &= ~SCF_DO_STCLASS_OR;
3272 /* Exclude from super-linear cache processing any {n,m}
3273 regops for which the combination of input pos and regex
3274 pos is not enough information to determine if a match
3277 For example, in the regex /foo(bar\s*){4,8}baz/ with the
3278 regex pos at the \s*, the prospects for a match depend not
3279 only on the input position but also on how many (bar\s*)
3280 repeats into the {4,8} we are. */
3281 if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
3282 f &= ~SCF_WHILEM_VISITED_POS;
3284 /* This will finish on WHILEM, setting scan, or on NULL: */
3285 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
3286 last, data, stopparen, recursed, NULL,
3288 ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
3290 if (flags & SCF_DO_STCLASS)
3291 data->start_class = oclass;
3292 if (mincount == 0 || minnext == 0) {
3293 if (flags & SCF_DO_STCLASS_OR) {
3294 cl_or(pRExC_state, data->start_class, &this_class);
3296 else if (flags & SCF_DO_STCLASS_AND) {
3297 /* Switch to OR mode: cache the old value of
3298 * data->start_class */
3300 StructCopy(data->start_class, and_withp,
3301 struct regnode_charclass_class);
3302 flags &= ~SCF_DO_STCLASS_AND;
3303 StructCopy(&this_class, data->start_class,
3304 struct regnode_charclass_class);
3305 flags |= SCF_DO_STCLASS_OR;
3306 data->start_class->flags |= ANYOF_EOS;
3308 } else { /* Non-zero len */
3309 if (flags & SCF_DO_STCLASS_OR) {
3310 cl_or(pRExC_state, data->start_class, &this_class);
3311 cl_and(data->start_class, and_withp);
3313 else if (flags & SCF_DO_STCLASS_AND)
3314 cl_and(data->start_class, &this_class);
3315 flags &= ~SCF_DO_STCLASS;
3317 if (!scan) /* It was not CURLYX, but CURLY. */
3319 if ( /* ? quantifier ok, except for (?{ ... }) */
3320 (next_is_eval || !(mincount == 0 && maxcount == 1))
3321 && (minnext == 0) && (deltanext == 0)
3322 && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3323 && maxcount <= REG_INFTY/3) /* Complement check for big count */
3325 ckWARNreg(RExC_parse,
3326 "Quantifier unexpected on zero-length expression");
3329 min += minnext * mincount;
3330 is_inf_internal |= ((maxcount == REG_INFTY
3331 && (minnext + deltanext) > 0)
3332 || deltanext == I32_MAX);
3333 is_inf |= is_inf_internal;
3334 delta += (minnext + deltanext) * maxcount - minnext * mincount;
3336 /* Try powerful optimization CURLYX => CURLYN. */
3337 if ( OP(oscan) == CURLYX && data
3338 && data->flags & SF_IN_PAR
3339 && !(data->flags & SF_HAS_EVAL)
3340 && !deltanext && minnext == 1 ) {
3341 /* Try to optimize to CURLYN. */
3342 regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3343 regnode * const nxt1 = nxt;
3350 if (!REGNODE_SIMPLE(OP(nxt))
3351 && !(PL_regkind[OP(nxt)] == EXACT
3352 && STR_LEN(nxt) == 1))
3358 if (OP(nxt) != CLOSE)
3360 if (RExC_open_parens) {
3361 RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3362 RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3364 /* Now we know that nxt2 is the only contents: */
3365 oscan->flags = (U8)ARG(nxt);
3367 OP(nxt1) = NOTHING; /* was OPEN. */
3370 OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3371 NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
3372 NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
3373 OP(nxt) = OPTIMIZED; /* was CLOSE. */
3374 OP(nxt + 1) = OPTIMIZED; /* was count. */
3375 NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
3380 /* Try optimization CURLYX => CURLYM. */
3381 if ( OP(oscan) == CURLYX && data
3382 && !(data->flags & SF_HAS_PAR)
3383 && !(data->flags & SF_HAS_EVAL)
3384 && !deltanext /* atom is fixed width */
3385 && minnext != 0 /* CURLYM can't handle zero width */
3387 /* XXXX How to optimize if data == 0? */
3388 /* Optimize to a simpler form. */
3389 regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3393 while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3394 && (OP(nxt2) != WHILEM))
3396 OP(nxt2) = SUCCEED; /* Whas WHILEM */
3397 /* Need to optimize away parenths. */
3398 if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
3399 /* Set the parenth number. */
3400 regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
3402 oscan->flags = (U8)ARG(nxt);
3403 if (RExC_open_parens) {
3404 RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3405 RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
3407 OP(nxt1) = OPTIMIZED; /* was OPEN. */
3408 OP(nxt) = OPTIMIZED; /* was CLOSE. */
3411 OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3412 OP(nxt + 1) = OPTIMIZED; /* was count. */
3413 NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
3414 NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
3417 while ( nxt1 && (OP(nxt1) != WHILEM)) {
3418 regnode *nnxt = regnext(nxt1);
3420 if (reg_off_by_arg[OP(nxt1)])
3421 ARG_SET(nxt1, nxt2 - nxt1);
3422 else if (nxt2 - nxt1 < U16_MAX)
3423 NEXT_OFF(nxt1) = nxt2 - nxt1;
3425 OP(nxt) = NOTHING; /* Cannot beautify */
3430 /* Optimize again: */
3431 study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
3432 NULL, stopparen, recursed, NULL, 0,depth+1);
3437 else if ((OP(oscan) == CURLYX)
3438 && (flags & SCF_WHILEM_VISITED_POS)
3439 /* See the comment on a similar expression above.
3440 However, this time it's not a subexpression
3441 we care about, but the expression itself. */
3442 && (maxcount == REG_INFTY)
3443 && data && ++data->whilem_c < 16) {
3444 /* This stays as CURLYX, we can put the count/of pair. */
3445 /* Find WHILEM (as in regexec.c) */
3446 regnode *nxt = oscan + NEXT_OFF(oscan);
3448 if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
3450 PREVOPER(nxt)->flags = (U8)(data->whilem_c
3451 | (RExC_whilem_seen << 4)); /* On WHILEM */
3453 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
3455 if (flags & SCF_DO_SUBSTR) {
3456 SV *last_str = NULL;
3457 int counted = mincount != 0;
3459 if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
3460 #if defined(SPARC64_GCC_WORKAROUND)
3463 const char *s = NULL;
3466 if (pos_before >= data->last_start_min)
3469 b = data->last_start_min;
3472 s = SvPV_const(data->last_found, l);
3473 old = b - data->last_start_min;
3476 I32 b = pos_before >= data->last_start_min
3477 ? pos_before : data->last_start_min;
3479 const char * const s = SvPV_const(data->last_found, l);
3480 I32 old = b - data->last_start_min;
3484 old = utf8_hop((U8*)s, old) - (U8*)s;
3486 /* Get the added string: */
3487 last_str = newSVpvn_utf8(s + old, l, UTF);
3488 if (deltanext == 0 && pos_before == b) {
3489 /* What was added is a constant string */
3491 SvGROW(last_str, (mincount * l) + 1);
3492 repeatcpy(SvPVX(last_str) + l,
3493 SvPVX_const(last_str), l, mincount - 1);
3494 SvCUR_set(last_str, SvCUR(last_str) * mincount);
3495 /* Add additional parts. */
3496 SvCUR_set(data->last_found,
3497 SvCUR(data->last_found) - l);
3498 sv_catsv(data->last_found, last_str);
3500 SV * sv = data->last_found;
3502 SvUTF8(sv) && SvMAGICAL(sv) ?
3503 mg_find(sv, PERL_MAGIC_utf8) : NULL;
3504 if (mg && mg->mg_len >= 0)
3505 mg->mg_len += CHR_SVLEN(last_str) - l;
3507 data->last_end += l * (mincount - 1);
3510 /* start offset must point into the last copy */
3511 data->last_start_min += minnext * (mincount - 1);
3512 data->last_start_max += is_inf ? I32_MAX
3513 : (maxcount - 1) * (minnext + data->pos_delta);
3516 /* It is counted once already... */
3517 data->pos_min += minnext * (mincount - counted);
3518 data->pos_delta += - counted * deltanext +
3519 (minnext + deltanext) * maxcount - minnext * mincount;
3520 if (mincount != maxcount) {
3521 /* Cannot extend fixed substrings found inside
3523 SCAN_COMMIT(pRExC_state,data,minlenp);
3524 if (mincount && last_str) {
3525 SV * const sv = data->last_found;
3526 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3527 mg_find(sv, PERL_MAGIC_utf8) : NULL;
3531 sv_setsv(sv, last_str);
3532 data->last_end = data->pos_min;
3533 data->last_start_min =
3534 data->pos_min - CHR_SVLEN(last_str);
3535 data->last_start_max = is_inf
3537 : data->pos_min + data->pos_delta
3538 - CHR_SVLEN(last_str);
3540 data->longest = &(data->longest_float);
3542 SvREFCNT_dec(last_str);
3544 if (data && (fl & SF_HAS_EVAL))
3545 data->flags |= SF_HAS_EVAL;
3546 optimize_curly_tail:
3547 if (OP(oscan) != CURLYX) {
3548 while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
3550 NEXT_OFF(oscan) += NEXT_OFF(next);
3553 default: /* REF, ANYOFV, and CLUMP only? */
3554 if (flags & SCF_DO_SUBSTR) {
3555 SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
3556 data->longest = &(data->longest_float);
3558 is_inf = is_inf_internal = 1;
3559 if (flags & SCF_DO_STCLASS_OR)
3560 cl_anything(pRExC_state, data->start_class);
3561 flags &= ~SCF_DO_STCLASS;
3565 else if (OP(scan) == LNBREAK) {
3566 if (flags & SCF_DO_STCLASS) {
3568 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
3569 if (flags & SCF_DO_STCLASS_AND) {
3570 for (value = 0; value < 256; value++)
3571 if (!is_VERTWS_cp(value))
3572 ANYOF_BITMAP_CLEAR(data->start_class, value);
3575 for (value = 0; value < 256; value++)
3576 if (is_VERTWS_cp(value))
3577 ANYOF_BITMAP_SET(data->start_class, value);
3579 if (flags & SCF_DO_STCLASS_OR)
3580 cl_and(data->start_class, and_withp);
3581 flags &= ~SCF_DO_STCLASS;
3585 if (flags & SCF_DO_SUBSTR) {
3586 SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
3588 data->pos_delta += 1;
3589 data->longest = &(data->longest_float);
3592 else if (OP(scan) == FOLDCHAR) {
3593 int d = ARG(scan) == LATIN_SMALL_LETTER_SHARP_S ? 1 : 2;
3594 flags &= ~SCF_DO_STCLASS;
3597 if (flags & SCF_DO_SUBSTR) {
3598 SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
3600 data->pos_delta += d;
3601 data->longest = &(data->longest_float);
3604 else if (REGNODE_SIMPLE(OP(scan))) {
3607 if (flags & SCF_DO_SUBSTR) {
3608 SCAN_COMMIT(pRExC_state,data,minlenp);
3612 if (flags & SCF_DO_STCLASS) {
3613 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
3615 /* Some of the logic below assumes that switching
3616 locale on will only add false positives. */
3617 switch (PL_regkind[OP(scan)]) {
3621 /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
3622 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3623 cl_anything(pRExC_state, data->start_class);
3626 if (OP(scan) == SANY)
3628 if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
3629 value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
3630 || ANYOF_CLASS_TEST_ANY_SET(data->start_class));
3631 cl_anything(pRExC_state, data->start_class);
3633 if (flags & SCF_DO_STCLASS_AND || !value)
3634 ANYOF_BITMAP_CLEAR(data->start_class,'\n');
3637 if (flags & SCF_DO_STCLASS_AND)
3638 cl_and(data->start_class,
3639 (struct regnode_charclass_class*)scan);
3641 cl_or(pRExC_state, data->start_class,
3642 (struct regnode_charclass_class*)scan);
3645 if (flags & SCF_DO_STCLASS_AND) {
3646 if (!(data->start_class->flags & ANYOF_LOCALE)) {
3647 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
3648 if (OP(scan) == ALNUMU) {
3649 for (value = 0; value < 256; value++) {
3650 if (!isWORDCHAR_L1(value)) {
3651 ANYOF_BITMAP_CLEAR(data->start_class, value);
3655 for (value = 0; value < 256; value++) {
3656 if (!isALNUM(value)) {
3657 ANYOF_BITMAP_CLEAR(data->start_class, value);
3664 if (data->start_class->flags & ANYOF_LOCALE)
3665 ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
3666 else if (OP(scan) == ALNUMU) {
3667 for (value = 0; value < 256; value++) {
3668 if (isWORDCHAR_L1(value)) {
3669 ANYOF_BITMAP_SET(data->start_class, value);
3673 for (value = 0; value < 256; value++) {
3674 if (isALNUM(value)) {
3675 ANYOF_BITMAP_SET(data->start_class, value);
3682 if (flags & SCF_DO_STCLASS_AND) {
3683 if (!(data->start_class->flags & ANYOF_LOCALE)) {
3684 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
3685 if (OP(scan) == NALNUMU) {
3686 for (value = 0; value < 256; value++) {
3687 if (isWORDCHAR_L1(value)) {
3688 ANYOF_BITMAP_CLEAR(data->start_class, value);
3692 for (value = 0; value < 256; value++) {
3693 if (isALNUM(value)) {
3694 ANYOF_BITMAP_CLEAR(data->start_class, value);
3701 if (data->start_class->flags & ANYOF_LOCALE)
3702 ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
3704 if (OP(scan) == NALNUMU) {
3705 for (value = 0; value < 256; value++) {
3706 if (! isWORDCHAR_L1(value)) {
3707 ANYOF_BITMAP_SET(data->start_class, value);
3711 for (value = 0; value < 256; value++) {
3712 if (! isALNUM(value)) {
3713 ANYOF_BITMAP_SET(data->start_class, value);
3721 if (flags & SCF_DO_STCLASS_AND) {
3722 if (!(data->start_class->flags & ANYOF_LOCALE)) {
3723 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
3724 if (OP(scan) == SPACEU) {
3725 for (value = 0; value < 256; value++) {
3726 if (!isSPACE_L1(value)) {
3727 ANYOF_BITMAP_CLEAR(data->start_class, value);
3731 for (value = 0; value < 256; value++) {
3732 if (!isSPACE(value)) {
3733 ANYOF_BITMAP_CLEAR(data->start_class, value);
3740 if (data->start_class->flags & ANYOF_LOCALE) {
3741 ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
3743 else if (OP(scan) == SPACEU) {
3744 for (value = 0; value < 256; value++) {
3745 if (isSPACE_L1(value)) {
3746 ANYOF_BITMAP_SET(data->start_class, value);
3750 for (value = 0; value < 256; value++) {
3751 if (isSPACE(value)) {
3752 ANYOF_BITMAP_SET(data->start_class, value);
3759 if (flags & SCF_DO_STCLASS_AND) {
3760 if (!(data->start_class->flags & ANYOF_LOCALE)) {
3761 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
3762 if (OP(scan) == NSPACEU) {
3763 for (value = 0; value < 256; value++) {
3764 if (isSPACE_L1(value)) {
3765 ANYOF_BITMAP_CLEAR(data->start_class, value);
3769 for (value = 0; value < 256; value++) {
3770 if (isSPACE(value)) {
3771 ANYOF_BITMAP_CLEAR(data->start_class, value);
3778 if (data->start_class->flags & ANYOF_LOCALE)
3779 ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
3780 else if (OP(scan) == NSPACEU) {
3781 for (value = 0; value < 256; value++) {
3782 if (!isSPACE_L1(value)) {
3783 ANYOF_BITMAP_SET(data->start_class, value);
3788 for (value = 0; value < 256; value++) {
3789 if (!isSPACE(value)) {
3790 ANYOF_BITMAP_SET(data->start_class, value);
3797 if (flags & SCF_DO_STCLASS_AND) {
3798 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
3799 for (value = 0; value < 256; value++)
3800 if (!isDIGIT(value))
3801 ANYOF_BITMAP_CLEAR(data->start_class, value);
3804 if (data->start_class->flags & ANYOF_LOCALE)
3805 ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
3807 for (value = 0; value < 256; value++)
3809 ANYOF_BITMAP_SET(data->start_class, value);
3814 if (flags & SCF_DO_STCLASS_AND) {
3815 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
3816 for (value = 0; value < 256; value++)
3818 ANYOF_BITMAP_CLEAR(data->start_class, value);
3821 if (data->start_class->flags & ANYOF_LOCALE)
3822 ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
3824 for (value = 0; value < 256; value++)
3825 if (!isDIGIT(value))
3826 ANYOF_BITMAP_SET(data->start_class, value);
3830 CASE_SYNST_FNC(VERTWS);
3831 CASE_SYNST_FNC(HORIZWS);
3834 if (flags & SCF_DO_STCLASS_OR)
3835 cl_and(data->start_class, and_withp);
3836 flags &= ~SCF_DO_STCLASS;
3839 else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
3840 data->flags |= (OP(scan) == MEOL
3844 else if ( PL_regkind[OP(scan)] == BRANCHJ
3845 /* Lookbehind, or need to calculate parens/evals/stclass: */
3846 && (scan->flags || data || (flags & SCF_DO_STCLASS))
3847 && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
3848 if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
3849 || OP(scan) == UNLESSM )
3851 /* Negative Lookahead/lookbehind
3852 In this case we can't do fixed string optimisation.
3855 I32 deltanext, minnext, fake = 0;
3857 struct regnode_charclass_class intrnl;
3860 data_fake.flags = 0;
3862 data_fake.whilem_c = data->whilem_c;
3863 data_fake.last_closep = data->last_closep;
3866 data_fake.last_closep = &fake;
3867 data_fake.pos_delta = delta;
3868 if ( flags & SCF_DO_STCLASS && !scan->flags
3869 && OP(scan) == IFMATCH ) { /* Lookahead */
3870 cl_init(pRExC_state, &intrnl);
3871 data_fake.start_class = &intrnl;
3872 f |= SCF_DO_STCLASS_AND;
3874 if (flags & SCF_WHILEM_VISITED_POS)
3875 f |= SCF_WHILEM_VISITED_POS;
3876 next = regnext(scan);
3877 nscan = NEXTOPER(NEXTOPER(scan));
3878 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
3879 last, &data_fake, stopparen, recursed, NULL, f, depth+1);
3882 FAIL("Variable length lookbehind not implemented");
3884 else if (minnext > (I32)U8_MAX) {
3885 FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
3887 scan->flags = (U8)minnext;
3890 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3892 if (data_fake.flags & SF_HAS_EVAL)
3893 data->flags |= SF_HAS_EVAL;
3894 data->whilem_c = data_fake.whilem_c;
3896 if (f & SCF_DO_STCLASS_AND) {
3897 if (flags & SCF_DO_STCLASS_OR) {
3898 /* OR before, AND after: ideally we would recurse with
3899 * data_fake to get the AND applied by study of the
3900 * remainder of the pattern, and then derecurse;
3901 * *** HACK *** for now just treat as "no information".
3902 * See [perl #56690].
3904 cl_init(pRExC_state, data->start_class);
3906 /* AND before and after: combine and continue */
3907 const int was = (data->start_class->flags & ANYOF_EOS);
3909 cl_and(data->start_class, &intrnl);
3911 data->start_class->flags |= ANYOF_EOS;
3915 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
3917 /* Positive Lookahead/lookbehind
3918 In this case we can do fixed string optimisation,
3919 but we must be careful about it. Note in the case of
3920 lookbehind the positions will be offset by the minimum
3921 length of the pattern, something we won't know about
3922 until after the recurse.
3924 I32 deltanext, fake = 0;
3926 struct regnode_charclass_class intrnl;
3928 /* We use SAVEFREEPV so that when the full compile
3929 is finished perl will clean up the allocated
3930 minlens when it's all done. This way we don't
3931 have to worry about freeing them when we know
3932 they wont be used, which would be a pain.
3935 Newx( minnextp, 1, I32 );
3936 SAVEFREEPV(minnextp);
3939 StructCopy(data, &data_fake, scan_data_t);
3940 if ((flags & SCF_DO_SUBSTR) && data->last_found) {
3943 SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
3944 data_fake.last_found=newSVsv(data->last_found);
3948 data_fake.last_closep = &fake;
3949 data_fake.flags = 0;
3950 data_fake.pos_delta = delta;
3952 data_fake.flags |= SF_IS_INF;
3953 if ( flags & SCF_DO_STCLASS && !scan->flags
3954 && OP(scan) == IFMATCH ) { /* Lookahead */
3955 cl_init(pRExC_state, &intrnl);
3956 data_fake.start_class = &intrnl;
3957 f |= SCF_DO_STCLASS_AND;
3959 if (flags & SCF_WHILEM_VISITED_POS)
3960 f |= SCF_WHILEM_VISITED_POS;
3961 next = regnext(scan);
3962 nscan = NEXTOPER(NEXTOPER(scan));
3964 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext,
3965 last, &data_fake, stopparen, recursed, NULL, f,depth+1);
3968 FAIL("Variable length lookbehind not implemented");
3970 else if (*minnextp > (I32)U8_MAX) {
3971 FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
3973 scan->flags = (U8)*minnextp;
3978 if (f & SCF_DO_STCLASS_AND) {
3979 const int was = (data->start_class->flags & ANYOF_EOS);
3981 cl_and(data->start_class, &intrnl);
3983 data->start_class->flags |= ANYOF_EOS;
3986 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3988 if (data_fake.flags & SF_HAS_EVAL)
3989 data->flags |= SF_HAS_EVAL;
3990 data->whilem_c = data_fake.whilem_c;
3991 if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
3992 if (RExC_rx->minlen<*minnextp)
3993 RExC_rx->minlen=*minnextp;
3994 SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
3995 SvREFCNT_dec(data_fake.last_found);
3997 if ( data_fake.minlen_fixed != minlenp )
3999 data->offset_fixed= data_fake.offset_fixed;
4000 data->minlen_fixed= data_fake.minlen_fixed;
4001 data->lookbehind_fixed+= scan->flags;
4003 if ( data_fake.minlen_float != minlenp )
4005 data->minlen_float= data_fake.minlen_float;
4006 data->offset_float_min=data_fake.offset_float_min;
4007 data->offset_float_max=data_fake.offset_float_max;
4008 data->lookbehind_float+= scan->flags;
4017 else if (OP(scan) == OPEN) {
4018 if (stopparen != (I32)ARG(scan))
4021 else if (OP(scan) == CLOSE) {
4022 if (stopparen == (I32)ARG(scan)) {
4025 if ((I32)ARG(scan) == is_par) {
4026 next = regnext(scan);
4028 if ( next && (OP(next) != WHILEM) && next < last)
4029 is_par = 0; /* Disable optimization */
4032 *(data->last_closep) = ARG(scan);
4034 else if (OP(scan) == EVAL) {
4036 data->flags |= SF_HAS_EVAL;
4038 else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
4039 if (flags & SCF_DO_SUBSTR) {
4040 SCAN_COMMIT(pRExC_state,data,minlenp);
4041 flags &= ~SCF_DO_SUBSTR;
4043 if (data && OP(scan)==ACCEPT) {
4044 data->flags |= SCF_SEEN_ACCEPT;
4049 else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
4051 if (flags & SCF_DO_SUBSTR) {
4052 SCAN_COMMIT(pRExC_state,data,minlenp);
4053 data->longest = &(data->longest_float);
4055 is_inf = is_inf_internal = 1;
4056 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4057 cl_anything(pRExC_state, data->start_class);
4058 flags &= ~SCF_DO_STCLASS;
4060 else if (OP(scan) == GPOS) {
4061 if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
4062 !(delta || is_inf || (data && data->pos_delta)))
4064 if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
4065 RExC_rx->extflags |= RXf_ANCH_GPOS;
4066 if (RExC_rx->gofs < (U32)min)
4067 RExC_rx->gofs = min;
4069 RExC_rx->extflags |= RXf_GPOS_FLOAT;
4073 #ifdef TRIE_STUDY_OPT
4074 #ifdef FULL_TRIE_STUDY
4075 else if (PL_regkind[OP(scan)] == TRIE) {
4076 /* NOTE - There is similar code to this block above for handling
4077 BRANCH nodes on the initial study. If you change stuff here
4079 regnode *trie_node= scan;
4080 regnode *tail= regnext(scan);
4081 reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4082 I32 max1 = 0, min1 = I32_MAX;
4083 struct regnode_charclass_class accum;
4085 if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
4086 SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
4087 if (flags & SCF_DO_STCLASS)
4088 cl_init_zero(pRExC_state, &accum);
4094 const regnode *nextbranch= NULL;
4097 for ( word=1 ; word <= trie->wordcount ; word++)
4099 I32 deltanext=0, minnext=0, f = 0, fake;
4100 struct regnode_charclass_class this_class;
4102 data_fake.flags = 0;
4104 data_fake.whilem_c = data->whilem_c;
4105 data_fake.last_closep = data->last_closep;
4108 data_fake.last_closep = &fake;
4109 data_fake.pos_delta = delta;
4110 if (flags & SCF_DO_STCLASS) {
4111 cl_init(pRExC_state, &this_class);
4112 data_fake.start_class = &this_class;
4113 f = SCF_DO_STCLASS_AND;
4115 if (flags & SCF_WHILEM_VISITED_POS)
4116 f |= SCF_WHILEM_VISITED_POS;
4118 if (trie->jump[word]) {
4120 nextbranch = trie_node + trie->jump[0];
4121 scan= trie_node + trie->jump[word];
4122 /* We go from the jump point to the branch that follows
4123 it. Note this means we need the vestigal unused branches
4124 even though they arent otherwise used.
4126 minnext = study_chunk(pRExC_state, &scan, minlenp,
4127 &deltanext, (regnode *)nextbranch, &data_fake,
4128 stopparen, recursed, NULL, f,depth+1);
4130 if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
4131 nextbranch= regnext((regnode*)nextbranch);
4133 if (min1 > (I32)(minnext + trie->minlen))
4134 min1 = minnext + trie->minlen;
4135 if (max1 < (I32)(minnext + deltanext + trie->maxlen))
4136 max1 = minnext + deltanext + trie->maxlen;
4137 if (deltanext == I32_MAX)
4138 is_inf = is_inf_internal = 1;
4140 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4142 if (data_fake.flags & SCF_SEEN_ACCEPT) {
4143 if ( stopmin > min + min1)
4144 stopmin = min + min1;
4145 flags &= ~SCF_DO_SUBSTR;
4147 data->flags |= SCF_SEEN_ACCEPT;
4150 if (data_fake.flags & SF_HAS_EVAL)
4151 data->flags |= SF_HAS_EVAL;
4152 data->whilem_c = data_fake.whilem_c;
4154 if (flags & SCF_DO_STCLASS)
4155 cl_or(pRExC_state, &accum, &this_class);
4158 if (flags & SCF_DO_SUBSTR) {
4159 data->pos_min += min1;
4160 data->pos_delta += max1 - min1;
4161 if (max1 != min1 || is_inf)
4162 data->longest = &(data->longest_float);
4165 delta += max1 - min1;
4166 if (flags & SCF_DO_STCLASS_OR) {
4167 cl_or(pRExC_state, data->start_class, &accum);
4169 cl_and(data->start_class, and_withp);
4170 flags &= ~SCF_DO_STCLASS;
4173 else if (flags & SCF_DO_STCLASS_AND) {
4175 cl_and(data->start_class, &accum);
4176 flags &= ~SCF_DO_STCLASS;
4179 /* Switch to OR mode: cache the old value of
4180 * data->start_class */
4182 StructCopy(data->start_class, and_withp,
4183 struct regnode_charclass_class);
4184 flags &= ~SCF_DO_STCLASS_AND;
4185 StructCopy(&accum, data->start_class,
4186 struct regnode_charclass_class);
4187 flags |= SCF_DO_STCLASS_OR;
4188 data->start_class->flags |= ANYOF_EOS;
4195 else if (PL_regkind[OP(scan)] == TRIE) {
4196 reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4199 min += trie->minlen;
4200 delta += (trie->maxlen - trie->minlen);
4201 flags &= ~SCF_DO_STCLASS; /* xxx */
4202 if (flags & SCF_DO_SUBSTR) {
4203 SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
4204 data->pos_min += trie->minlen;
4205 data->pos_delta += (trie->maxlen - trie->minlen);
4206 if (trie->maxlen != trie->minlen)
4207 data->longest = &(data->longest_float);
4209 if (trie->jump) /* no more substrings -- for now /grr*/
4210 flags &= ~SCF_DO_SUBSTR;
4212 #endif /* old or new */
4213 #endif /* TRIE_STUDY_OPT */
4215 /* Else: zero-length, ignore. */
4216 scan = regnext(scan);
4221 stopparen = frame->stop;
4222 frame = frame->prev;
4223 goto fake_study_recurse;
4228 DEBUG_STUDYDATA("pre-fin:",data,depth);
4231 *deltap = is_inf_internal ? I32_MAX : delta;
4232 if (flags & SCF_DO_SUBSTR && is_inf)
4233 data->pos_delta = I32_MAX - data->pos_min;
4234 if (is_par > (I32)U8_MAX)
4236 if (is_par && pars==1 && data) {
4237 data->flags |= SF_IN_PAR;
4238 data->flags &= ~SF_HAS_PAR;
4240 else if (pars && data) {
4241 data->flags |= SF_HAS_PAR;
4242 data->flags &= ~SF_IN_PAR;
4244 if (flags & SCF_DO_STCLASS_OR)
4245 cl_and(data->start_class, and_withp);
4246 if (flags & SCF_TRIE_RESTUDY)
4247 data->flags |= SCF_TRIE_RESTUDY;
4249 DEBUG_STUDYDATA("post-fin:",data,depth);
4251 return min < stopmin ? min : stopmin;
4255 S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s)
4257 U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
4259 PERL_ARGS_ASSERT_ADD_DATA;
4261 Renewc(RExC_rxi->data,
4262 sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
4263 char, struct reg_data);
4265 Renew(RExC_rxi->data->what, count + n, U8);
4267 Newx(RExC_rxi->data->what, n, U8);
4268 RExC_rxi->data->count = count + n;
4269 Copy(s, RExC_rxi->data->what + count, n, U8);
4273 /*XXX: todo make this not included in a non debugging perl */
4274 #ifndef PERL_IN_XSUB_RE
4276 Perl_reginitcolors(pTHX)
4279 const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
4281 char *t = savepv(s);
4285 t = strchr(t, '\t');
4291 PL_colors[i] = t = (char *)"";
4296 PL_colors[i++] = (char *)"";
4303 #ifdef TRIE_STUDY_OPT
4304 #define CHECK_RESTUDY_GOTO \
4306 (data.flags & SCF_TRIE_RESTUDY) \
4310 #define CHECK_RESTUDY_GOTO
4314 - pregcomp - compile a regular expression into internal code
4316 * We can't allocate space until we know how big the compiled form will be,
4317 * but we can't compile it (and thus know how big it is) until we've got a
4318 * place to put the code. So we cheat: we compile it twice, once with code
4319 * generation turned off and size counting turned on, and once "for real".
4320 * This also means that we don't allocate space until we are sure that the
4321 * thing really will compile successfully, and we never have to move the
4322 * code and thus invalidate pointers into it. (Note that it has to be in
4323 * one piece because free() must be able to free it all.) [NB: not true in perl]
4325 * Beware that the optimization-preparation code in here knows about some
4326 * of the structure of the compiled regexp. [I'll say.]
4331 #ifndef PERL_IN_XSUB_RE
4332 #define RE_ENGINE_PTR &PL_core_reg_engine
4334 extern const struct regexp_engine my_reg_engine;
4335 #define RE_ENGINE_PTR &my_reg_engine
4338 #ifndef PERL_IN_XSUB_RE
4340 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
4343 HV * const table = GvHV(PL_hintgv);
4345 PERL_ARGS_ASSERT_PREGCOMP;
4347 /* Dispatch a request to compile a regexp to correct
4350 SV **ptr= hv_fetchs(table, "regcomp", FALSE);
4351 GET_RE_DEBUG_FLAGS_DECL;
4352 if (ptr && SvIOK(*ptr) && SvIV(*ptr)) {
4353 const regexp_engine *eng=INT2PTR(regexp_engine*,SvIV(*ptr));
4355 PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
4358 return CALLREGCOMP_ENG(eng, pattern, flags);
4361 return Perl_re_compile(aTHX_ pattern, flags);
4366 Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
4371 register regexp_internal *ri;
4380 /* these are all flags - maybe they should be turned
4381 * into a single int with different bit masks */
4382 I32 sawlookahead = 0;
4385 bool used_setjump = FALSE;
4390 RExC_state_t RExC_state;
4391 RExC_state_t * const pRExC_state = &RExC_state;
4392 #ifdef TRIE_STUDY_OPT
4394 RExC_state_t copyRExC_state;
4396 GET_RE_DEBUG_FLAGS_DECL;
4398 PERL_ARGS_ASSERT_RE_COMPILE;
4400 DEBUG_r(if (!PL_colorset) reginitcolors());
4402 RExC_utf8 = RExC_orig_utf8 = SvUTF8(pattern);
4403 RExC_uni_semantics = 0;
4405 /****************** LONG JUMP TARGET HERE***********************/
4406 /* Longjmp back to here if have to switch in midstream to utf8 */
4407 if (! RExC_orig_utf8) {
4408 JMPENV_PUSH(jump_ret);
4409 used_setjump = TRUE;
4412 if (jump_ret == 0) { /* First time through */
4413 exp = SvPV(pattern, plen);
4415 /* ignore the utf8ness if the pattern is 0 length */
4417 RExC_utf8 = RExC_orig_utf8 = 0;
4421 SV *dsv= sv_newmortal();
4422 RE_PV_QUOTED_DECL(s, RExC_utf8,
4423 dsv, exp, plen, 60);
4424 PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
4425 PL_colors[4],PL_colors[5],s);
4428 else { /* longjumped back */
4431 /* If the cause for the longjmp was other than changing to utf8, pop
4432 * our own setjmp, and longjmp to the correct handler */
4433 if (jump_ret != UTF8_LONGJMP) {
4435 JMPENV_JUMP(jump_ret);
4440 /* It's possible to write a regexp in ascii that represents Unicode
4441 codepoints outside of the byte range, such as via \x{100}. If we
4442 detect such a sequence we have to convert the entire pattern to utf8
4443 and then recompile, as our sizing calculation will have been based
4444 on 1 byte == 1 character, but we will need to use utf8 to encode
4445 at least some part of the pattern, and therefore must convert the whole
4448 DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
4449 "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
4450 exp = (char*)Perl_bytes_to_utf8(aTHX_ (U8*)SvPV(pattern, plen), &len);
4452 RExC_orig_utf8 = RExC_utf8 = 1;
4456 #ifdef TRIE_STUDY_OPT
4460 /* Set to use unicode semantics if the pattern is in utf8 and has the
4461 * 'depends' charset specified, as it means unicode when utf8 */
4462 pm_flags = orig_pm_flags;
4464 if (RExC_utf8 && get_regex_charset(pm_flags) == REGEX_DEPENDS_CHARSET) {
4465 set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
4469 RExC_flags = pm_flags;
4473 RExC_in_lookbehind = 0;
4474 RExC_seen_zerolen = *exp == '^' ? -1 : 0;
4475 RExC_seen_evals = 0;
4478 /* First pass: determine size, legality. */
4486 RExC_emit = &PL_regdummy;
4487 RExC_whilem_seen = 0;
4488 RExC_open_parens = NULL;
4489 RExC_close_parens = NULL;
4491 RExC_paren_names = NULL;
4493 RExC_paren_name_list = NULL;
4495 RExC_recurse = NULL;
4496 RExC_recurse_count = 0;
4498 #if 0 /* REGC() is (currently) a NOP at the first pass.
4499 * Clever compilers notice this and complain. --jhi */
4500 REGC((U8)REG_MAGIC, (char*)RExC_emit);
4502 DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n"));
4503 if (reg(pRExC_state, 0, &flags,1) == NULL) {
4504 RExC_precomp = NULL;
4508 /* Here, finished first pass. Get rid of any added setjmp */
4514 PerlIO_printf(Perl_debug_log,
4515 "Required size %"IVdf" nodes\n"
4516 "Starting second pass (creation)\n",
4519 RExC_lastparse=NULL;
4522 /* The first pass could have found things that force Unicode semantics */
4523 if ((RExC_utf8 || RExC_uni_semantics)
4524 && get_regex_charset(pm_flags) == REGEX_DEPENDS_CHARSET)
4526 set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
4529 /* Small enough for pointer-storage convention?
4530 If extralen==0, this means that we will not need long jumps. */
4531 if (RExC_size >= 0x10000L && RExC_extralen)
4532 RExC_size += RExC_extralen;
4535 if (RExC_whilem_seen > 15)
4536 RExC_whilem_seen = 15;
4538 /* Allocate space and zero-initialize. Note, the two step process
4539 of zeroing when in debug mode, thus anything assigned has to
4540 happen after that */
4541 rx = (REGEXP*) newSV_type(SVt_REGEXP);
4542 r = (struct regexp*)SvANY(rx);
4543 Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
4544 char, regexp_internal);
4545 if ( r == NULL || ri == NULL )
4546 FAIL("Regexp out of space");
4548 /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
4549 Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
4551 /* bulk initialize base fields with 0. */
4552 Zero(ri, sizeof(regexp_internal), char);
4555 /* non-zero initialization begins here */
4557 r->engine= RE_ENGINE_PTR;
4558 r->extflags = pm_flags;
4560 bool has_p = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
4561 bool has_charset = (get_regex_charset(r->extflags) != REGEX_DEPENDS_CHARSET);
4563 /* The caret is output if there are any defaults: if not all the STD
4564 * flags are set, or if no character set specifier is needed */
4566 (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
4568 bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT);
4569 U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
4570 >> RXf_PMf_STD_PMMOD_SHIFT);
4571 const char *fptr = STD_PAT_MODS; /*"msix"*/
4573 /* Allocate for the worst case, which is all the std flags are turned
4574 * on. If more precision is desired, we could do a population count of
4575 * the flags set. This could be done with a small lookup table, or by
4576 * shifting, masking and adding, or even, when available, assembly
4577 * language for a machine-language population count.
4578 * We never output a minus, as all those are defaults, so are
4579 * covered by the caret */
4580 const STRLEN wraplen = plen + has_p + has_runon
4581 + has_default /* If needs a caret */
4583 /* If needs a character set specifier */
4584 + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
4585 + (sizeof(STD_PAT_MODS) - 1)
4586 + (sizeof("(?:)") - 1);
4588 p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
4590 SvFLAGS(rx) |= SvUTF8(pattern);
4593 /* If a default, cover it using the caret */
4595 *p++= DEFAULT_PAT_MOD;
4599 const char* const name = get_regex_charset_name(r->extflags, &len);
4600 Copy(name, p, len, char);
4604 *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
4607 while((ch = *fptr++)) {
4615 Copy(RExC_precomp, p, plen, char);
4616 assert ((RX_WRAPPED(rx) - p) < 16);
4617 r->pre_prefix = p - RX_WRAPPED(rx);
4623 SvCUR_set(rx, p - SvPVX_const(rx));
4627 r->nparens = RExC_npar - 1; /* set early to validate backrefs */
4629 if (RExC_seen & REG_SEEN_RECURSE) {
4630 Newxz(RExC_open_parens, RExC_npar,regnode *);
4631 SAVEFREEPV(RExC_open_parens);
4632 Newxz(RExC_close_parens,RExC_npar,regnode *);
4633 SAVEFREEPV(RExC_close_parens);
4636 /* Useful during FAIL. */
4637 #ifdef RE_TRACK_PATTERN_OFFSETS
4638 Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
4639 DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
4640 "%s %"UVuf" bytes for offset annotations.\n",
4641 ri->u.offsets ? "Got" : "Couldn't get",
4642 (UV)((2*RExC_size+1) * sizeof(U32))));
4644 SetProgLen(ri,RExC_size);
4649 /* Second pass: emit code. */
4650 RExC_flags = pm_flags; /* don't let top level (?i) bleed */
4655 RExC_emit_start = ri->program;
4656 RExC_emit = ri->program;
4657 RExC_emit_bound = ri->program + RExC_size + 1;
4659 /* Store the count of eval-groups for security checks: */
4660 RExC_rx->seen_evals = RExC_seen_evals;
4661 REGC((U8)REG_MAGIC, (char*) RExC_emit++);
4662 if (reg(pRExC_state, 0, &flags,1) == NULL) {
4666 /* XXXX To minimize changes to RE engine we always allocate
4667 3-units-long substrs field. */
4668 Newx(r->substrs, 1, struct reg_substr_data);
4669 if (RExC_recurse_count) {
4670 Newxz(RExC_recurse,RExC_recurse_count,regnode *);
4671 SAVEFREEPV(RExC_recurse);
4675 r->minlen = minlen = sawlookahead = sawplus = sawopen = 0;
4676 Zero(r->substrs, 1, struct reg_substr_data);
4678 #ifdef TRIE_STUDY_OPT
4680 StructCopy(&zero_scan_data, &data, scan_data_t);
4681 copyRExC_state = RExC_state;
4684 DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
4686 RExC_state = copyRExC_state;
4687 if (seen & REG_TOP_LEVEL_BRANCHES)
4688 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
4690 RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
4691 if (data.last_found) {
4692 SvREFCNT_dec(data.longest_fixed);
4693 SvREFCNT_dec(data.longest_float);
4694 SvREFCNT_dec(data.last_found);
4696 StructCopy(&zero_scan_data, &data, scan_data_t);
4699 StructCopy(&zero_scan_data, &data, scan_data_t);
4702 /* Dig out information for optimizations. */
4703 r->extflags = RExC_flags; /* was pm_op */
4704 /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
4707 SvUTF8_on(rx); /* Unicode in it? */
4708 ri->regstclass = NULL;
4709 if (RExC_naughty >= 10) /* Probably an expensive pattern. */
4710 r->intflags |= PREGf_NAUGHTY;
4711 scan = ri->program + 1; /* First BRANCH. */
4713 /* testing for BRANCH here tells us whether there is "must appear"
4714 data in the pattern. If there is then we can use it for optimisations */
4715 if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /* Only one top-level choice. */
4717 STRLEN longest_float_length, longest_fixed_length;
4718 struct regnode_charclass_class ch_class; /* pointed to by data */
4720 I32 last_close = 0; /* pointed to by data */
4721 regnode *first= scan;
4722 regnode *first_next= regnext(first);
4724 * Skip introductions and multiplicators >= 1
4725 * so that we can extract the 'meat' of the pattern that must
4726 * match in the large if() sequence following.
4727 * NOTE that EXACT is NOT covered here, as it is normally
4728 * picked up by the optimiser separately.
4730 * This is unfortunate as the optimiser isnt handling lookahead
4731 * properly currently.
4734 while ((OP(first) == OPEN && (sawopen = 1)) ||
4735 /* An OR of *one* alternative - should not happen now. */
4736 (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
4737 /* for now we can't handle lookbehind IFMATCH*/
4738 (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
4739 (OP(first) == PLUS) ||
4740 (OP(first) == MINMOD) ||
4741 /* An {n,m} with n>0 */
4742 (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
4743 (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
4746 * the only op that could be a regnode is PLUS, all the rest
4747 * will be regnode_1 or regnode_2.
4750 if (OP(first) == PLUS)
4753 first += regarglen[OP(first)];
4755 first = NEXTOPER(first);
4756 first_next= regnext(first);
4759 /* Starting-point info. */
4761 DEBUG_PEEP("first:",first,0);
4762 /* Ignore EXACT as we deal with it later. */
4763 if (PL_regkind[OP(first)] == EXACT) {
4764 if (OP(first) == EXACT)
4765 NOOP; /* Empty, get anchored substr later. */
4767 ri->regstclass = first;
4770 else if (PL_regkind[OP(first)] == TRIE &&
4771 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0)
4774 /* this can happen only on restudy */
4775 if ( OP(first) == TRIE ) {
4776 struct regnode_1 *trieop = (struct regnode_1 *)
4777 PerlMemShared_calloc(1, sizeof(struct regnode_1));
4778 StructCopy(first,trieop,struct regnode_1);
4779 trie_op=(regnode *)trieop;
4781 struct regnode_charclass *trieop = (struct regnode_charclass *)
4782 PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
4783 StructCopy(first,trieop,struct regnode_charclass);
4784 trie_op=(regnode *)trieop;
4787 make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
4788 ri->regstclass = trie_op;
4791 else if (REGNODE_SIMPLE(OP(first)))
4792 ri->regstclass = first;
4793 else if (PL_regkind[OP(first)] == BOUND ||
4794 PL_regkind[OP(first)] == NBOUND)
4795 ri->regstclass = first;
4796 else if (PL_regkind[OP(first)] == BOL) {
4797 r->extflags |= (OP(first) == MBOL
4799 : (OP(first) == SBOL
4802 first = NEXTOPER(first);
4805 else if (OP(first) == GPOS) {
4806 r->extflags |= RXf_ANCH_GPOS;
4807 first = NEXTOPER(first);
4810 else if ((!sawopen || !RExC_sawback) &&
4811 (OP(first) == STAR &&
4812 PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
4813 !(r->extflags & RXf_ANCH) && !(RExC_seen & REG_SEEN_EVAL))
4815 /* turn .* into ^.* with an implied $*=1 */
4817 (OP(NEXTOPER(first)) == REG_ANY)
4820 r->extflags |= type;
4821 r->intflags |= PREGf_IMPLICIT;
4822 first = NEXTOPER(first);
4825 if (sawplus && !sawlookahead && (!sawopen || !RExC_sawback)
4826 && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
4827 /* x+ must match at the 1st pos of run of x's */
4828 r->intflags |= PREGf_SKIP;
4830 /* Scan is after the zeroth branch, first is atomic matcher. */
4831 #ifdef TRIE_STUDY_OPT
4834 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
4835 (IV)(first - scan + 1))
4839 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
4840 (IV)(first - scan + 1))
4846 * If there's something expensive in the r.e., find the
4847 * longest literal string that must appear and make it the
4848 * regmust. Resolve ties in favor of later strings, since
4849 * the regstart check works with the beginning of the r.e.
4850 * and avoiding duplication strengthens checking. Not a
4851 * strong reason, but sufficient in the absence of others.
4852 * [Now we resolve ties in favor of the earlier string if
4853 * it happens that c_offset_min has been invalidated, since the
4854 * earlier string may buy us something the later one won't.]
4857 data.longest_fixed = newSVpvs("");
4858 data.longest_float = newSVpvs("");
4859 data.last_found = newSVpvs("");
4860 data.longest = &(data.longest_fixed);
4862 if (!ri->regstclass) {
4863 cl_init(pRExC_state, &ch_class);
4864 data.start_class = &ch_class;
4865 stclass_flag = SCF_DO_STCLASS_AND;
4866 } else /* XXXX Check for BOUND? */
4868 data.last_closep = &last_close;
4870 minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
4871 &data, -1, NULL, NULL,
4872 SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
4878 if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
4879 && data.last_start_min == 0 && data.last_end > 0
4880 && !RExC_seen_zerolen
4881 && !(RExC_seen & REG_SEEN_VERBARG)
4882 && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
4883 r->extflags |= RXf_CHECK_ALL;
4884 scan_commit(pRExC_state, &data,&minlen,0);
4885 SvREFCNT_dec(data.last_found);
4887 /* Note that code very similar to this but for anchored string
4888 follows immediately below, changes may need to be made to both.
4891 longest_float_length = CHR_SVLEN(data.longest_float);
4892 if (longest_float_length
4893 || (data.flags & SF_FL_BEFORE_EOL
4894 && (!(data.flags & SF_FL_BEFORE_MEOL)
4895 || (RExC_flags & RXf_PMf_MULTILINE))))
4899 if (SvCUR(data.longest_fixed) /* ok to leave SvCUR */
4900 && data.offset_fixed == data.offset_float_min
4901 && SvCUR(data.longest_fixed) == SvCUR(data.longest_float))
4902 goto remove_float; /* As in (a)+. */
4904 /* copy the information about the longest float from the reg_scan_data
4905 over to the program. */
4906 if (SvUTF8(data.longest_float)) {
4907 r->float_utf8 = data.longest_float;
4908 r->float_substr = NULL;
4910 r->float_substr = data.longest_float;
4911 r->float_utf8 = NULL;
4913 /* float_end_shift is how many chars that must be matched that
4914 follow this item. We calculate it ahead of time as once the
4915 lookbehind offset is added in we lose the ability to correctly
4917 ml = data.minlen_float ? *(data.minlen_float)
4918 : (I32)longest_float_length;
4919 r->float_end_shift = ml - data.offset_float_min
4920 - longest_float_length + (SvTAIL(data.longest_float) != 0)
4921 + data.lookbehind_float;
4922 r->float_min_offset = data.offset_float_min - data.lookbehind_float;
4923 r->float_max_offset = data.offset_float_max;
4924 if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
4925 r->float_max_offset -= data.lookbehind_float;
4927 t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
4928 && (!(data.flags & SF_FL_BEFORE_MEOL)
4929 || (RExC_flags & RXf_PMf_MULTILINE)));
4930 fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
4934 r->float_substr = r->float_utf8 = NULL;
4935 SvREFCNT_dec(data.longest_float);
4936 longest_float_length = 0;
4939 /* Note that code very similar to this but for floating string
4940 is immediately above, changes may need to be made to both.
4943 longest_fixed_length = CHR_SVLEN(data.longest_fixed);
4944 if (longest_fixed_length
4945 || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
4946 && (!(data.flags & SF_FIX_BEFORE_MEOL)
4947 || (RExC_flags & RXf_PMf_MULTILINE))))
4951 /* copy the information about the longest fixed
4952 from the reg_scan_data over to the program. */
4953 if (SvUTF8(data.longest_fixed)) {
4954 r->anchored_utf8 = data.longest_fixed;
4955 r->anchored_substr = NULL;
4957 r->anchored_substr = data.longest_fixed;
4958 r->anchored_utf8 = NULL;
4960 /* fixed_end_shift is how many chars that must be matched that
4961 follow this item. We calculate it ahead of time as once the
4962 lookbehind offset is added in we lose the ability to correctly
4964 ml = data.minlen_fixed ? *(data.minlen_fixed)
4965 : (I32)longest_fixed_length;
4966 r->anchored_end_shift = ml - data.offset_fixed
4967 - longest_fixed_length + (SvTAIL(data.longest_fixed) != 0)
4968 + data.lookbehind_fixed;
4969 r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
4971 t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
4972 && (!(data.flags & SF_FIX_BEFORE_MEOL)
4973 || (RExC_flags & RXf_PMf_MULTILINE)));
4974 fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
4977 r->anchored_substr = r->anchored_utf8 = NULL;
4978 SvREFCNT_dec(data.longest_fixed);
4979 longest_fixed_length = 0;
4982 && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
4983 ri->regstclass = NULL;
4985 /* If the synthetic start class were to ever be used when EOS is set,
4986 * that bit would have to be cleared, as it is shared with another */
4987 if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
4989 && !(data.start_class->flags & ANYOF_EOS)
4990 && !cl_is_anything(data.start_class))
4992 const U32 n = add_data(pRExC_state, 1, "f");
4994 Newx(RExC_rxi->data->data[n], 1,
4995 struct regnode_charclass_class);
4996 StructCopy(data.start_class,
4997 (struct regnode_charclass_class*)RExC_rxi->data->data[n],
4998 struct regnode_charclass_class);
4999 ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5000 r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5001 DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
5002 regprop(r, sv, (regnode*)data.start_class);
5003 PerlIO_printf(Perl_debug_log,
5004 "synthetic stclass \"%s\".\n",
5005 SvPVX_const(sv));});
5008 /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
5009 if (longest_fixed_length > longest_float_length) {
5010 r->check_end_shift = r->anchored_end_shift;
5011 r->check_substr = r->anchored_substr;
5012 r->check_utf8 = r->anchored_utf8;
5013 r->check_offset_min = r->check_offset_max = r->anchored_offset;
5014 if (r->extflags & RXf_ANCH_SINGLE)
5015 r->extflags |= RXf_NOSCAN;
5018 r->check_end_shift = r->float_end_shift;
5019 r->check_substr = r->float_substr;
5020 r->check_utf8 = r->float_utf8;
5021 r->check_offset_min = r->float_min_offset;
5022 r->check_offset_max = r->float_max_offset;
5024 /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
5025 This should be changed ASAP! */
5026 if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
5027 r->extflags |= RXf_USE_INTUIT;
5028 if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
5029 r->extflags |= RXf_INTUIT_TAIL;
5031 /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
5032 if ( (STRLEN)minlen < longest_float_length )
5033 minlen= longest_float_length;
5034 if ( (STRLEN)minlen < longest_fixed_length )
5035 minlen= longest_fixed_length;
5039 /* Several toplevels. Best we can is to set minlen. */
5041 struct regnode_charclass_class ch_class;
5044 DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
5046 scan = ri->program + 1;
5047 cl_init(pRExC_state, &ch_class);
5048 data.start_class = &ch_class;
5049 data.last_closep = &last_close;
5052 minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
5053 &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
5057 r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
5058 = r->float_substr = r->float_utf8 = NULL;
5060 /* If the synthetic start class were to ever be used when EOS is set,
5061 * that bit would have to be cleared, as it is shared with another */
5062 if (!(data.start_class->flags & ANYOF_EOS)
5063 && !cl_is_anything(data.start_class))
5065 const U32 n = add_data(pRExC_state, 1, "f");
5067 Newx(RExC_rxi->data->data[n], 1,
5068 struct regnode_charclass_class);
5069 StructCopy(data.start_class,
5070 (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5071 struct regnode_charclass_class);
5072 ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5073 r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5074 DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
5075 regprop(r, sv, (regnode*)data.start_class);
5076 PerlIO_printf(Perl_debug_log,
5077 "synthetic stclass \"%s\".\n",
5078 SvPVX_const(sv));});
5082 /* Guard against an embedded (?=) or (?<=) with a longer minlen than
5083 the "real" pattern. */
5085 PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
5086 (IV)minlen, (IV)r->minlen);
5088 r->minlenret = minlen;
5089 if (r->minlen < minlen)
5092 if (RExC_seen & REG_SEEN_GPOS)
5093 r->extflags |= RXf_GPOS_SEEN;
5094 if (RExC_seen & REG_SEEN_LOOKBEHIND)
5095 r->extflags |= RXf_LOOKBEHIND_SEEN;
5096 if (RExC_seen & REG_SEEN_EVAL)
5097 r->extflags |= RXf_EVAL_SEEN;
5098 if (RExC_seen & REG_SEEN_CANY)
5099 r->extflags |= RXf_CANY_SEEN;
5100 if (RExC_seen & REG_SEEN_VERBARG)
5101 r->intflags |= PREGf_VERBARG_SEEN;
5102 if (RExC_seen & REG_SEEN_CUTGROUP)
5103 r->intflags |= PREGf_CUTGROUP_SEEN;
5104 if (RExC_paren_names)
5105 RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
5107 RXp_PAREN_NAMES(r) = NULL;
5109 #ifdef STUPID_PATTERN_CHECKS
5110 if (RX_PRELEN(rx) == 0)
5111 r->extflags |= RXf_NULL;
5112 if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5113 /* XXX: this should happen BEFORE we compile */
5114 r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
5115 else if (RX_PRELEN(rx) == 3 && memEQ("\\s+", RX_PRECOMP(rx), 3))
5116 r->extflags |= RXf_WHITE;
5117 else if (RX_PRELEN(rx) == 1 && RXp_PRECOMP(rx)[0] == '^')
5118 r->extflags |= RXf_START_ONLY;
5120 if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5121 /* XXX: this should happen BEFORE we compile */
5122 r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
5124 regnode *first = ri->program + 1;
5127 if (PL_regkind[fop] == NOTHING && OP(NEXTOPER(first)) == END)
5128 r->extflags |= RXf_NULL;
5129 else if (PL_regkind[fop] == BOL && OP(NEXTOPER(first)) == END)
5130 r->extflags |= RXf_START_ONLY;
5131 else if (fop == PLUS && OP(NEXTOPER(first)) == SPACE
5132 && OP(regnext(first)) == END)
5133 r->extflags |= RXf_WHITE;
5137 if (RExC_paren_names) {
5138 ri->name_list_idx = add_data( pRExC_state, 1, "a" );
5139 ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
5142 ri->name_list_idx = 0;
5144 if (RExC_recurse_count) {
5145 for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
5146 const regnode *scan = RExC_recurse[RExC_recurse_count-1];
5147 ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
5150 Newxz(r->offs, RExC_npar, regexp_paren_pair);
5151 /* assume we don't need to swap parens around before we match */
5154 PerlIO_printf(Perl_debug_log,"Final program:\n");
5157 #ifdef RE_TRACK_PATTERN_OFFSETS
5158 DEBUG_OFFSETS_r(if (ri->u.offsets) {
5159 const U32 len = ri->u.offsets[0];
5161 GET_RE_DEBUG_FLAGS_DECL;
5162 PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
5163 for (i = 1; i <= len; i++) {
5164 if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
5165 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
5166 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
5168 PerlIO_printf(Perl_debug_log, "\n");
5174 #undef RE_ENGINE_PTR
5178 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
5181 PERL_ARGS_ASSERT_REG_NAMED_BUFF;
5183 PERL_UNUSED_ARG(value);
5185 if (flags & RXapif_FETCH) {
5186 return reg_named_buff_fetch(rx, key, flags);
5187 } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
5188 Perl_croak_no_modify(aTHX);
5190 } else if (flags & RXapif_EXISTS) {
5191 return reg_named_buff_exists(rx, key, flags)
5194 } else if (flags & RXapif_REGNAMES) {
5195 return reg_named_buff_all(rx, flags);
5196 } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
5197 return reg_named_buff_scalar(rx, flags);
5199 Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
5205 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
5208 PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
5209 PERL_UNUSED_ARG(lastkey);
5211 if (flags & RXapif_FIRSTKEY)
5212 return reg_named_buff_firstkey(rx, flags);
5213 else if (flags & RXapif_NEXTKEY)
5214 return reg_named_buff_nextkey(rx, flags);
5216 Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", (int)flags);
5222 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
5225 AV *retarray = NULL;
5227 struct regexp *const rx = (struct regexp *)SvANY(r);
5229 PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
5231 if (flags & RXapif_ALL)
5234 if (rx && RXp_PAREN_NAMES(rx)) {
5235 HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
5238 SV* sv_dat=HeVAL(he_str);
5239 I32 *nums=(I32*)SvPVX(sv_dat);
5240 for ( i=0; i<SvIVX(sv_dat); i++ ) {
5241 if ((I32)(rx->nparens) >= nums[i]
5242 && rx->offs[nums[i]].start != -1
5243 && rx->offs[nums[i]].end != -1)
5246 CALLREG_NUMBUF_FETCH(r,nums[i],ret);
5250 ret = newSVsv(&PL_sv_undef);
5253 av_push(retarray, ret);
5256 return newRV_noinc(MUTABLE_SV(retarray));
5263 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
5266 struct regexp *const rx = (struct regexp *)SvANY(r);
5268 PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
5270 if (rx && RXp_PAREN_NAMES(rx)) {
5271 if (flags & RXapif_ALL) {
5272 return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
5274 SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
5288 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
5290 struct regexp *const rx = (struct regexp *)SvANY(r);
5292 PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
5294 if ( rx && RXp_PAREN_NAMES(rx) ) {
5295 (void)hv_iterinit(RXp_PAREN_NAMES(rx));
5297 return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
5304 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
5306 struct regexp *const rx = (struct regexp *)SvANY(r);
5307 GET_RE_DEBUG_FLAGS_DECL;
5309 PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
5311 if (rx && RXp_PAREN_NAMES(rx)) {
5312 HV *hv = RXp_PAREN_NAMES(rx);
5314 while ( (temphe = hv_iternext_flags(hv,0)) ) {
5317 SV* sv_dat = HeVAL(temphe);
5318 I32 *nums = (I32*)SvPVX(sv_dat);
5319 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5320 if ((I32)(rx->lastparen) >= nums[i] &&
5321 rx->offs[nums[i]].start != -1 &&
5322 rx->offs[nums[i]].end != -1)
5328 if (parno || flags & RXapif_ALL) {
5329 return newSVhek(HeKEY_hek(temphe));
5337 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
5342 struct regexp *const rx = (struct regexp *)SvANY(r);
5344 PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
5346 if (rx && RXp_PAREN_NAMES(rx)) {
5347 if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
5348 return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
5349 } else if (flags & RXapif_ONE) {
5350 ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
5351 av = MUTABLE_AV(SvRV(ret));
5352 length = av_len(av);
5354 return newSViv(length + 1);
5356 Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
5360 return &PL_sv_undef;
5364 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
5366 struct regexp *const rx = (struct regexp *)SvANY(r);
5369 PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
5371 if (rx && RXp_PAREN_NAMES(rx)) {
5372 HV *hv= RXp_PAREN_NAMES(rx);
5374 (void)hv_iterinit(hv);
5375 while ( (temphe = hv_iternext_flags(hv,0)) ) {
5378 SV* sv_dat = HeVAL(temphe);
5379 I32 *nums = (I32*)SvPVX(sv_dat);
5380 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5381 if ((I32)(rx->lastparen) >= nums[i] &&
5382 rx->offs[nums[i]].start != -1 &&
5383 rx->offs[nums[i]].end != -1)
5389 if (parno || flags & RXapif_ALL) {
5390 av_push(av, newSVhek(HeKEY_hek(temphe)));
5395 return newRV_noinc(MUTABLE_SV(av));
5399 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
5402 struct regexp *const rx = (struct regexp *)SvANY(r);
5407 PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
5410 sv_setsv(sv,&PL_sv_undef);
5414 if (paren == RX_BUFF_IDX_PREMATCH && rx->offs[0].start != -1) {
5416 i = rx->offs[0].start;
5420 if (paren == RX_BUFF_IDX_POSTMATCH && rx->offs[0].end != -1) {
5422 s = rx->subbeg + rx->offs[0].end;
5423 i = rx->sublen - rx->offs[0].end;
5426 if ( 0 <= paren && paren <= (I32)rx->nparens &&
5427 (s1 = rx->offs[paren].start) != -1 &&
5428 (t1 = rx->offs[paren].end) != -1)
5432 s = rx->subbeg + s1;
5434 sv_setsv(sv,&PL_sv_undef);
5437 assert(rx->sublen >= (s - rx->subbeg) + i );
5439 const int oldtainted = PL_tainted;
5441 sv_setpvn(sv, s, i);
5442 PL_tainted = oldtainted;
5443 if ( (rx->extflags & RXf_CANY_SEEN)
5444 ? (RXp_MATCH_UTF8(rx)
5445 && (!i || is_utf8_string((U8*)s, i)))
5446 : (RXp_MATCH_UTF8(rx)) )
5453 if (RXp_MATCH_TAINTED(rx)) {
5454 if (SvTYPE(sv) >= SVt_PVMG) {
5455 MAGIC* const mg = SvMAGIC(sv);
5458 SvMAGIC_set(sv, mg->mg_moremagic);
5460 if ((mgt = SvMAGIC(sv))) {
5461 mg->mg_moremagic = mgt;
5462 SvMAGIC_set(sv, mg);
5472 sv_setsv(sv,&PL_sv_undef);
5478 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
5479 SV const * const value)
5481 PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
5483 PERL_UNUSED_ARG(rx);
5484 PERL_UNUSED_ARG(paren);
5485 PERL_UNUSED_ARG(value);
5488 Perl_croak_no_modify(aTHX);
5492 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
5495 struct regexp *const rx = (struct regexp *)SvANY(r);
5499 PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
5501 /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
5503 /* $` / ${^PREMATCH} */
5504 case RX_BUFF_IDX_PREMATCH:
5505 if (rx->offs[0].start != -1) {
5506 i = rx->offs[0].start;
5514 /* $' / ${^POSTMATCH} */
5515 case RX_BUFF_IDX_POSTMATCH:
5516 if (rx->offs[0].end != -1) {
5517 i = rx->sublen - rx->offs[0].end;
5519 s1 = rx->offs[0].end;
5525 /* $& / ${^MATCH}, $1, $2, ... */
5527 if (paren <= (I32)rx->nparens &&
5528 (s1 = rx->offs[paren].start) != -1 &&
5529 (t1 = rx->offs[paren].end) != -1)
5534 if (ckWARN(WARN_UNINITIALIZED))
5535 report_uninit((const SV *)sv);
5540 if (i > 0 && RXp_MATCH_UTF8(rx)) {
5541 const char * const s = rx->subbeg + s1;
5546 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
5553 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
5555 PERL_ARGS_ASSERT_REG_QR_PACKAGE;
5556 PERL_UNUSED_ARG(rx);
5560 return newSVpvs("Regexp");
5563 /* Scans the name of a named buffer from the pattern.
5564 * If flags is REG_RSN_RETURN_NULL returns null.
5565 * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
5566 * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
5567 * to the parsed name as looked up in the RExC_paren_names hash.
5568 * If there is an error throws a vFAIL().. type exception.
5571 #define REG_RSN_RETURN_NULL 0
5572 #define REG_RSN_RETURN_NAME 1
5573 #define REG_RSN_RETURN_DATA 2
5576 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
5578 char *name_start = RExC_parse;
5580 PERL_ARGS_ASSERT_REG_SCAN_NAME;
5582 if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
5583 /* skip IDFIRST by using do...while */
5586 RExC_parse += UTF8SKIP(RExC_parse);
5587 } while (isALNUM_utf8((U8*)RExC_parse));
5591 } while (isALNUM(*RExC_parse));
5596 = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
5597 SVs_TEMP | (UTF ? SVf_UTF8 : 0));
5598 if ( flags == REG_RSN_RETURN_NAME)
5600 else if (flags==REG_RSN_RETURN_DATA) {
5603 if ( ! sv_name ) /* should not happen*/
5604 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
5605 if (RExC_paren_names)
5606 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
5608 sv_dat = HeVAL(he_str);
5610 vFAIL("Reference to nonexistent named group");
5614 Perl_croak(aTHX_ "panic: bad flag in reg_scan_name");
5621 #define DEBUG_PARSE_MSG(funcname) DEBUG_PARSE_r({ \
5622 int rem=(int)(RExC_end - RExC_parse); \
5631 if (RExC_lastparse!=RExC_parse) \
5632 PerlIO_printf(Perl_debug_log," >%.*s%-*s", \
5635 iscut ? "..." : "<" \
5638 PerlIO_printf(Perl_debug_log,"%16s",""); \
5641 num = RExC_size + 1; \
5643 num=REG_NODE_NUM(RExC_emit); \
5644 if (RExC_lastnum!=num) \
5645 PerlIO_printf(Perl_debug_log,"|%4d",num); \
5647 PerlIO_printf(Perl_debug_log,"|%4s",""); \
5648 PerlIO_printf(Perl_debug_log,"|%*s%-4s", \
5649 (int)((depth*2)), "", \
5653 RExC_lastparse=RExC_parse; \
5658 #define DEBUG_PARSE(funcname) DEBUG_PARSE_r({ \
5659 DEBUG_PARSE_MSG((funcname)); \
5660 PerlIO_printf(Perl_debug_log,"%4s","\n"); \
5662 #define DEBUG_PARSE_FMT(funcname,fmt,args) DEBUG_PARSE_r({ \
5663 DEBUG_PARSE_MSG((funcname)); \
5664 PerlIO_printf(Perl_debug_log,fmt "\n",args); \
5667 /* This section of code defines the inversion list object and its methods. The
5668 * interfaces are highly subject to change, so as much as possible is static to
5669 * this file. An inversion list is here implemented as a malloc'd C array with
5670 * some added info. More will be coming when functionality is added later.
5672 * Some of the methods should always be private to the implementation, and some
5673 * should eventually be made public */
5675 #define INVLIST_INITIAL_LEN 10
5676 #define INVLIST_ARRAY_KEY "array"
5677 #define INVLIST_MAX_KEY "max"
5678 #define INVLIST_LEN_KEY "len"
5680 PERL_STATIC_INLINE UV*
5681 S_invlist_array(pTHX_ HV* const invlist)
5683 /* Returns the pointer to the inversion list's array. Every time the
5684 * length changes, this needs to be called in case malloc or realloc moved
5687 SV** list_ptr = hv_fetchs(invlist, INVLIST_ARRAY_KEY, FALSE);
5689 PERL_ARGS_ASSERT_INVLIST_ARRAY;
5691 if (list_ptr == NULL) {
5692 Perl_croak(aTHX_ "panic: inversion list without a '%s' element",
5696 return INT2PTR(UV *, SvUV(*list_ptr));
5699 PERL_STATIC_INLINE void
5700 S_invlist_set_array(pTHX_ HV* const invlist, const UV* const array)
5702 PERL_ARGS_ASSERT_INVLIST_SET_ARRAY;
5704 /* Sets the array stored in the inversion list to the memory beginning with
5707 if (hv_stores(invlist, INVLIST_ARRAY_KEY, newSVuv(PTR2UV(array))) == NULL) {
5708 Perl_croak(aTHX_ "panic: can't store '%s' entry in inversion list",
5713 PERL_STATIC_INLINE UV
5714 S_invlist_len(pTHX_ HV* const invlist)
5716 /* Returns the current number of elements in the inversion list's array */
5718 SV** len_ptr = hv_fetchs(invlist, INVLIST_LEN_KEY, FALSE);
5720 PERL_ARGS_ASSERT_INVLIST_LEN;
5722 if (len_ptr == NULL) {
5723 Perl_croak(aTHX_ "panic: inversion list without a '%s' element",
5727 return SvUV(*len_ptr);
5730 PERL_STATIC_INLINE UV
5731 S_invlist_max(pTHX_ HV* const invlist)
5733 /* Returns the maximum number of elements storable in the inversion list's
5734 * array, without having to realloc() */
5736 SV** max_ptr = hv_fetchs(invlist, INVLIST_MAX_KEY, FALSE);
5738 PERL_ARGS_ASSERT_INVLIST_MAX;
5740 if (max_ptr == NULL) {
5741 Perl_croak(aTHX_ "panic: inversion list without a '%s' element",
5745 return SvUV(*max_ptr);
5748 PERL_STATIC_INLINE void
5749 S_invlist_set_len(pTHX_ HV* const invlist, const UV len)
5751 /* Sets the current number of elements stored in the inversion list */
5753 PERL_ARGS_ASSERT_INVLIST_SET_LEN;
5755 if (len != 0 && len > invlist_max(invlist)) {
5756 Perl_croak(aTHX_ "panic: Can't make '%s=%"UVuf"' more than %s=%"UVuf" in inversion list", INVLIST_LEN_KEY, len, INVLIST_MAX_KEY, invlist_max(invlist));
5759 if (hv_stores(invlist, INVLIST_LEN_KEY, newSVuv(len)) == NULL) {
5760 Perl_croak(aTHX_ "panic: can't store '%s' entry in inversion list",
5765 PERL_STATIC_INLINE void
5766 S_invlist_set_max(pTHX_ HV* const invlist, const UV max)
5769 /* Sets the maximum number of elements storable in the inversion list
5770 * without having to realloc() */
5772 PERL_ARGS_ASSERT_INVLIST_SET_MAX;
5774 if (max < invlist_len(invlist)) {
5775 Perl_croak(aTHX_ "panic: Can't make '%s=%"UVuf"' less than %s=%"UVuf" in inversion list", INVLIST_MAX_KEY, invlist_len(invlist), INVLIST_LEN_KEY, invlist_max(invlist));
5778 if (hv_stores(invlist, INVLIST_MAX_KEY, newSVuv(max)) == NULL) {
5779 Perl_croak(aTHX_ "panic: can't store '%s' entry in inversion list",
5784 #ifndef PERL_IN_XSUB_RE
5786 Perl__new_invlist(pTHX_ IV initial_size)
5789 /* Return a pointer to a newly constructed inversion list, with enough
5790 * space to store 'initial_size' elements. If that number is negative, a
5791 * system default is used instead */
5793 HV* invlist = newHV();
5796 if (initial_size < 0) {
5797 initial_size = INVLIST_INITIAL_LEN;
5800 /* Allocate the initial space */
5801 Newx(list, initial_size, UV);
5802 invlist_set_array(invlist, list);
5804 /* set_len has to come before set_max, as the latter inspects the len */
5805 invlist_set_len(invlist, 0);
5806 invlist_set_max(invlist, initial_size);
5812 PERL_STATIC_INLINE void
5813 S_invlist_destroy(pTHX_ HV* const invlist)
5815 /* Inversion list destructor */
5817 SV** list_ptr = hv_fetchs(invlist, INVLIST_ARRAY_KEY, FALSE);
5819 PERL_ARGS_ASSERT_INVLIST_DESTROY;
5821 if (list_ptr != NULL) {
5822 Safefree(INT2PTR(UV *, SvUV(*list_ptr)));
5827 S_invlist_extend(pTHX_ HV* const invlist, const UV new_max)
5829 /* Change the maximum size of an inversion list (up or down) */
5833 const UV old_max = invlist_max(invlist);
5835 PERL_ARGS_ASSERT_INVLIST_EXTEND;
5837 if (old_max == new_max) { /* If a no-op */
5841 array = orig_array = invlist_array(invlist);
5842 Renew(array, new_max, UV);
5844 /* If the size change moved the list in memory, set the new one */
5845 if (array != orig_array) {
5846 invlist_set_array(invlist, array);
5849 invlist_set_max(invlist, new_max);
5853 PERL_STATIC_INLINE void
5854 S_invlist_trim(pTHX_ HV* const invlist)
5856 PERL_ARGS_ASSERT_INVLIST_TRIM;
5858 /* Change the length of the inversion list to how many entries it currently
5861 invlist_extend(invlist, invlist_len(invlist));
5864 /* An element is in an inversion list iff its index is even numbered: 0, 2, 4,
5867 #define ELEMENT_IN_INVLIST_SET(i) (! ((i) & 1))
5869 #ifndef PERL_IN_XSUB_RE
5871 Perl__append_range_to_invlist(pTHX_ HV* invlist, const UV start, const UV end)
5873 /* Subject to change or removal. Append the range from 'start' to 'end' at
5874 * the end of the inversion list. The range must be above any existing
5877 UV* array = invlist_array(invlist);
5878 UV max = invlist_max(invlist);
5879 UV len = invlist_len(invlist);
5881 PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
5885 /* Here, the existing list is non-empty. The current max entry in the
5886 * list is generally the first value not in the set, except when the
5887 * set extends to the end of permissible values, in which case it is
5888 * the first entry in that final set, and so this call is an attempt to
5889 * append out-of-order */
5891 UV final_element = len - 1;
5892 if (array[final_element] > start
5893 || ELEMENT_IN_INVLIST_SET(final_element))
5895 Perl_croak(aTHX_ "panic: attempting to append to an inversion list, but wasn't at the end of the list");
5898 /* Here, it is a legal append. If the new range begins with the first
5899 * value not in the set, it is extending the set, so the new first
5900 * value not in the set is one greater than the newly extended range.
5902 if (array[final_element] == start) {
5903 if (end != UV_MAX) {
5904 array[final_element] = end + 1;
5907 /* But if the end is the maximum representable on the machine,
5908 * just let the range that this would extend have no end */
5909 invlist_set_len(invlist, len - 1);
5915 /* Here the new range doesn't extend any existing set. Add it */
5917 len += 2; /* Includes an element each for the start and end of range */
5919 /* If overflows the existing space, extend, which may cause the array to be
5922 invlist_extend(invlist, len);
5923 array = invlist_array(invlist);
5926 invlist_set_len(invlist, len);
5928 /* The next item on the list starts the range, the one after that is
5929 * one past the new range. */
5930 array[len - 2] = start;
5931 if (end != UV_MAX) {
5932 array[len - 1] = end + 1;
5935 /* But if the end is the maximum representable on the machine, just let
5936 * the range have no end */
5937 invlist_set_len(invlist, len - 1);
5942 PERL_STATIC_INLINE HV*
5943 S_invlist_union(pTHX_ HV* const a, HV* const b)
5945 /* Return a new inversion list which is the union of two inversion lists.
5946 * The basis for this comes from "Unicode Demystified" Chapter 13 by
5947 * Richard Gillam, published by Addison-Wesley, and explained at some
5948 * length there. The preface says to incorporate its examples into your
5949 * code at your own risk.
5951 * The algorithm is like a merge sort.
5953 * XXX A potential performance improvement is to keep track as we go along
5954 * if only one of the inputs contributes to the result, meaning the other
5955 * is a subset of that one. In that case, we can skip the final copy and
5956 * return the larger of the input lists */
5958 UV* array_a = invlist_array(a); /* a's array */
5959 UV* array_b = invlist_array(b);
5960 UV len_a = invlist_len(a); /* length of a's array */
5961 UV len_b = invlist_len(b);
5963 HV* u; /* the resulting union */
5967 UV i_a = 0; /* current index into a's array */
5971 /* running count, as explained in the algorithm source book; items are
5972 * stopped accumulating and are output when the count changes to/from 0.
5973 * The count is incremented when we start a range that's in the set, and
5974 * decremented when we start a range that's not in the set. So its range
5975 * is 0 to 2. Only when the count is zero is something not in the set.
5979 PERL_ARGS_ASSERT_INVLIST_UNION;
5981 /* Size the union for the worst case: that the sets are completely
5983 u = _new_invlist(len_a + len_b);
5984 array_u = invlist_array(u);
5986 /* Go through each list item by item, stopping when exhausted one of
5988 while (i_a < len_a && i_b < len_b) {
5989 UV cp; /* The element to potentially add to the union's array */
5990 bool cp_in_set; /* is it in the the input list's set or not */
5992 /* We need to take one or the other of the two inputs for the union.
5993 * Since we are merging two sorted lists, we take the smaller of the
5994 * next items. In case of a tie, we take the one that is in its set
5995 * first. If we took one not in the set first, it would decrement the
5996 * count, possibly to 0 which would cause it to be output as ending the
5997 * range, and the next time through we would take the same number, and
5998 * output it again as beginning the next range. By doing it the
5999 * opposite way, there is no possibility that the count will be
6000 * momentarily decremented to 0, and thus the two adjoining ranges will
6001 * be seamlessly merged. (In a tie and both are in the set or both not
6002 * in the set, it doesn't matter which we take first.) */
6003 if (array_a[i_a] < array_b[i_b]
6004 || (array_a[i_a] == array_b[i_b] && ELEMENT_IN_INVLIST_SET(i_a)))
6006 cp_in_set = ELEMENT_IN_INVLIST_SET(i_a);
6010 cp_in_set = ELEMENT_IN_INVLIST_SET(i_b);
6014 /* Here, have chosen which of the two inputs to look at. Only output
6015 * if the running count changes to/from 0, which marks the
6016 * beginning/end of a range in that's in the set */
6019 array_u[i_u++] = cp;
6026 array_u[i_u++] = cp;
6031 /* Here, we are finished going through at least one of the lists, which
6032 * means there is something remaining in at most one. We check if the list
6033 * that hasn't been exhausted is positioned such that we are in the middle
6034 * of a range in its set or not. (We are in the set if the next item in
6035 * the array marks the beginning of something not in the set) If in the
6036 * set, we decrement 'count'; if 0, there is potentially more to output.
6037 * There are four cases:
6038 * 1) Both weren't in their sets, count is 0, and remains 0. What's left
6039 * in the union is entirely from the non-exhausted set.
6040 * 2) Both were in their sets, count is 2. Nothing further should
6041 * be output, as everything that remains will be in the exhausted
6042 * list's set, hence in the union; decrementing to 1 but not 0 insures
6044 * 3) the exhausted was in its set, non-exhausted isn't, count is 1.
6045 * Nothing further should be output because the union includes
6046 * everything from the exhausted set. Not decrementing insures that.
6047 * 4) the exhausted wasn't in its set, non-exhausted is, count is 1;
6048 * decrementing to 0 insures that we look at the remainder of the
6049 * non-exhausted set */
6050 if ((i_a != len_a && ! ELEMENT_IN_INVLIST_SET(i_a))
6051 || (i_b != len_b && ! ELEMENT_IN_INVLIST_SET(i_b)))
6056 /* The final length is what we've output so far, plus what else is about to
6057 * be output. (If 'count' is non-zero, then the input list we exhausted
6058 * has everything remaining up to the machine's limit in its set, and hence
6059 * in the union, so there will be no further output. */
6062 /* At most one of the subexpressions will be non-zero */
6063 len_u += (len_a - i_a) + (len_b - i_b);
6066 /* Set result to final length, which can change the pointer to array_u, so
6068 if (len_u != invlist_len(u)) {
6069 invlist_set_len(u, len_u);
6071 array_u = invlist_array(u);
6074 /* When 'count' is 0, the list that was exhausted (if one was shorter than
6075 * the other) ended with everything above it not in its set. That means
6076 * that the remaining part of the union is precisely the same as the
6077 * non-exhausted list, so can just copy it unchanged. (If both list were
6078 * exhausted at the same time, then the operations below will be both 0.)
6081 IV copy_count; /* At most one will have a non-zero copy count */
6082 if ((copy_count = len_a - i_a) > 0) {
6083 Copy(array_a + i_a, array_u + i_u, copy_count, UV);
6085 else if ((copy_count = len_b - i_b) > 0) {
6086 Copy(array_b + i_b, array_u + i_u, copy_count, UV);
6093 PERL_STATIC_INLINE HV*
6094 S_invlist_intersection(pTHX_ HV* const a, HV* const b)
6096 /* Return the intersection of two inversion lists. The basis for this
6097 * comes from "Unicode Demystified" Chapter 13 by Richard Gillam, published
6098 * by Addison-Wesley, and explained at some length there. The preface says
6099 * to incorporate its examples into your code at your own risk.
6101 * The algorithm is like a merge sort, and is essentially the same as the
6105 UV* array_a = invlist_array(a); /* a's array */
6106 UV* array_b = invlist_array(b);
6107 UV len_a = invlist_len(a); /* length of a's array */
6108 UV len_b = invlist_len(b);
6110 HV* r; /* the resulting intersection */
6114 UV i_a = 0; /* current index into a's array */
6118 /* running count, as explained in the algorithm source book; items are
6119 * stopped accumulating and are output when the count changes to/from 2.
6120 * The count is incremented when we start a range that's in the set, and
6121 * decremented when we start a range that's not in the set. So its range
6122 * is 0 to 2. Only when the count is 2 is something in the intersection.
6126 PERL_ARGS_ASSERT_INVLIST_INTERSECTION;
6128 /* Size the intersection for the worst case: that the intersection ends up
6129 * fragmenting everything to be completely disjoint */
6130 r= _new_invlist(len_a + len_b);
6131 array_r = invlist_array(r);
6133 /* Go through each list item by item, stopping when exhausted one of
6135 while (i_a < len_a && i_b < len_b) {
6136 UV cp; /* The element to potentially add to the intersection's
6138 bool cp_in_set; /* Is it in the input list's set or not */
6140 /* We need to take one or the other of the two inputs for the union.
6141 * Since we are merging two sorted lists, we take the smaller of the
6142 * next items. In case of a tie, we take the one that is not in its
6143 * set first (a difference from the union algorithm). If we took one
6144 * in the set first, it would increment the count, possibly to 2 which
6145 * would cause it to be output as starting a range in the intersection,
6146 * and the next time through we would take that same number, and output
6147 * it again as ending the set. By doing it the opposite of this, we
6148 * there is no possibility that the count will be momentarily
6149 * incremented to 2. (In a tie and both are in the set or both not in
6150 * the set, it doesn't matter which we take first.) */
6151 if (array_a[i_a] < array_b[i_b]
6152 || (array_a[i_a] == array_b[i_b] && ! ELEMENT_IN_INVLIST_SET(i_a)))
6154 cp_in_set = ELEMENT_IN_INVLIST_SET(i_a);
6158 cp_in_set = ELEMENT_IN_INVLIST_SET(i_b);
6162 /* Here, have chosen which of the two inputs to look at. Only output
6163 * if the running count changes to/from 2, which marks the
6164 * beginning/end of a range that's in the intersection */
6168 array_r[i_r++] = cp;
6173 array_r[i_r++] = cp;
6179 /* Here, we are finished going through at least one of the sets, which
6180 * means there is something remaining in at most one. See the comments in
6182 if ((i_a != len_a && ! ELEMENT_IN_INVLIST_SET(i_a))
6183 || (i_b != len_b && ! ELEMENT_IN_INVLIST_SET(i_b)))
6188 /* The final length is what we've output so far plus what else is in the
6189 * intersection. Only one of the subexpressions below will be non-zero */
6192 len_r += (len_a - i_a) + (len_b - i_b);
6195 /* Set result to final length, which can change the pointer to array_r, so
6197 if (len_r != invlist_len(r)) {
6198 invlist_set_len(r, len_r);
6200 array_r = invlist_array(r);
6203 /* Finish outputting any remaining */
6204 if (count == 2) { /* Only one of will have a non-zero copy count */
6206 if ((copy_count = len_a - i_a) > 0) {
6207 Copy(array_a + i_a, array_r + i_r, copy_count, UV);
6209 else if ((copy_count = len_b - i_b) > 0) {
6210 Copy(array_b + i_b, array_r + i_r, copy_count, UV);
6218 S_add_range_to_invlist(pTHX_ HV* const invlist, const UV start, const UV end)
6220 /* Add the range from 'start' to 'end' inclusive to the inversion list's
6221 * set. A pointer to the inversion list is returned. This may actually be
6222 * a new list, in which case the passed in one has been destroyed */
6227 UV len = invlist_len(invlist);
6229 PERL_ARGS_ASSERT_ADD_RANGE_TO_INVLIST;
6231 /* If comes after the final entry, can just append it to the end */
6233 || start >= invlist_array(invlist)
6234 [invlist_len(invlist) - 1])
6236 _append_range_to_invlist(invlist, start, end);
6240 /* Here, can't just append things, create and return a new inversion list
6241 * which is the union of this range and the existing inversion list */
6242 range_invlist = _new_invlist(2);
6243 _append_range_to_invlist(range_invlist, start, end);
6245 added_invlist = invlist_union(invlist, range_invlist);
6247 /* The passed in list can be freed, as well as our temporary */
6248 invlist_destroy(range_invlist);
6249 if (invlist != added_invlist) {
6250 invlist_destroy(invlist);
6253 return added_invlist;
6256 /* End of inversion list object */
6259 - reg - regular expression, i.e. main body or parenthesized thing
6261 * Caller must absorb opening parenthesis.
6263 * Combining parenthesis handling with the base level of regular expression
6264 * is a trifle forced, but the need to tie the tails of the branches to what
6265 * follows makes it hard to avoid.
6267 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
6269 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
6271 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
6275 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
6276 /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
6279 register regnode *ret; /* Will be the head of the group. */
6280 register regnode *br;
6281 register regnode *lastbr;
6282 register regnode *ender = NULL;
6283 register I32 parno = 0;
6285 U32 oregflags = RExC_flags;
6286 bool have_branch = 0;
6288 I32 freeze_paren = 0;
6289 I32 after_freeze = 0;
6291 /* for (?g), (?gc), and (?o) warnings; warning
6292 about (?c) will warn about (?g) -- japhy */
6294 #define WASTED_O 0x01
6295 #define WASTED_G 0x02
6296 #define WASTED_C 0x04
6297 #define WASTED_GC (0x02|0x04)
6298 I32 wastedflags = 0x00;
6300 char * parse_start = RExC_parse; /* MJD */
6301 char * const oregcomp_parse = RExC_parse;
6303 GET_RE_DEBUG_FLAGS_DECL;
6305 PERL_ARGS_ASSERT_REG;
6306 DEBUG_PARSE("reg ");
6308 *flagp = 0; /* Tentatively. */
6311 /* Make an OPEN node, if parenthesized. */
6313 if ( *RExC_parse == '*') { /* (*VERB:ARG) */
6314 char *start_verb = RExC_parse;
6315 STRLEN verb_len = 0;
6316 char *start_arg = NULL;
6317 unsigned char op = 0;
6319 int internal_argval = 0; /* internal_argval is only useful if !argok */
6320 while ( *RExC_parse && *RExC_parse != ')' ) {
6321 if ( *RExC_parse == ':' ) {
6322 start_arg = RExC_parse + 1;
6328 verb_len = RExC_parse - start_verb;
6331 while ( *RExC_parse && *RExC_parse != ')' )
6333 if ( *RExC_parse != ')' )
6334 vFAIL("Unterminated verb pattern argument");
6335 if ( RExC_parse == start_arg )
6338 if ( *RExC_parse != ')' )
6339 vFAIL("Unterminated verb pattern");
6342 switch ( *start_verb ) {
6343 case 'A': /* (*ACCEPT) */
6344 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
6346 internal_argval = RExC_nestroot;
6349 case 'C': /* (*COMMIT) */
6350 if ( memEQs(start_verb,verb_len,"COMMIT") )
6353 case 'F': /* (*FAIL) */
6354 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
6359 case ':': /* (*:NAME) */
6360 case 'M': /* (*MARK:NAME) */
6361 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
6366 case 'P': /* (*PRUNE) */
6367 if ( memEQs(start_verb,verb_len,"PRUNE") )
6370 case 'S': /* (*SKIP) */
6371 if ( memEQs(start_verb,verb_len,"SKIP") )
6374 case 'T': /* (*THEN) */
6375 /* [19:06] <TimToady> :: is then */
6376 if ( memEQs(start_verb,verb_len,"THEN") ) {
6378 RExC_seen |= REG_SEEN_CUTGROUP;
6384 vFAIL3("Unknown verb pattern '%.*s'",
6385 verb_len, start_verb);
6388 if ( start_arg && internal_argval ) {
6389 vFAIL3("Verb pattern '%.*s' may not have an argument",
6390 verb_len, start_verb);
6391 } else if ( argok < 0 && !start_arg ) {
6392 vFAIL3("Verb pattern '%.*s' has a mandatory argument",
6393 verb_len, start_verb);
6395 ret = reganode(pRExC_state, op, internal_argval);
6396 if ( ! internal_argval && ! SIZE_ONLY ) {
6398 SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
6399 ARG(ret) = add_data( pRExC_state, 1, "S" );
6400 RExC_rxi->data->data[ARG(ret)]=(void*)sv;
6407 if (!internal_argval)
6408 RExC_seen |= REG_SEEN_VERBARG;
6409 } else if ( start_arg ) {
6410 vFAIL3("Verb pattern '%.*s' may not have an argument",
6411 verb_len, start_verb);
6413 ret = reg_node(pRExC_state, op);
6415 nextchar(pRExC_state);
6418 if (*RExC_parse == '?') { /* (?...) */
6419 bool is_logical = 0;
6420 const char * const seqstart = RExC_parse;
6421 bool has_use_defaults = FALSE;
6424 paren = *RExC_parse++;
6425 ret = NULL; /* For look-ahead/behind. */
6428 case 'P': /* (?P...) variants for those used to PCRE/Python */
6429 paren = *RExC_parse++;
6430 if ( paren == '<') /* (?P<...>) named capture */
6432 else if (paren == '>') { /* (?P>name) named recursion */
6433 goto named_recursion;
6435 else if (paren == '=') { /* (?P=...) named backref */
6436 /* this pretty much dupes the code for \k<NAME> in regatom(), if
6437 you change this make sure you change that */
6438 char* name_start = RExC_parse;
6440 SV *sv_dat = reg_scan_name(pRExC_state,
6441 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6442 if (RExC_parse == name_start || *RExC_parse != ')')
6443 vFAIL2("Sequence %.3s... not terminated",parse_start);
6446 num = add_data( pRExC_state, 1, "S" );
6447 RExC_rxi->data->data[num]=(void*)sv_dat;
6448 SvREFCNT_inc_simple_void(sv_dat);
6451 ret = reganode(pRExC_state,
6462 Set_Node_Offset(ret, parse_start+1);
6463 Set_Node_Cur_Length(ret); /* MJD */
6465 nextchar(pRExC_state);
6469 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
6471 case '<': /* (?<...) */
6472 if (*RExC_parse == '!')
6474 else if (*RExC_parse != '=')
6480 case '\'': /* (?'...') */
6481 name_start= RExC_parse;
6482 svname = reg_scan_name(pRExC_state,
6483 SIZE_ONLY ? /* reverse test from the others */
6484 REG_RSN_RETURN_NAME :
6485 REG_RSN_RETURN_NULL);
6486 if (RExC_parse == name_start) {
6488 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
6491 if (*RExC_parse != paren)
6492 vFAIL2("Sequence (?%c... not terminated",
6493 paren=='>' ? '<' : paren);
6497 if (!svname) /* shouldn't happen */
6499 "panic: reg_scan_name returned NULL");
6500 if (!RExC_paren_names) {
6501 RExC_paren_names= newHV();
6502 sv_2mortal(MUTABLE_SV(RExC_paren_names));
6504 RExC_paren_name_list= newAV();
6505 sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
6508 he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
6510 sv_dat = HeVAL(he_str);
6512 /* croak baby croak */
6514 "panic: paren_name hash element allocation failed");
6515 } else if ( SvPOK(sv_dat) ) {
6516 /* (?|...) can mean we have dupes so scan to check
6517 its already been stored. Maybe a flag indicating
6518 we are inside such a construct would be useful,
6519 but the arrays are likely to be quite small, so
6520 for now we punt -- dmq */
6521 IV count = SvIV(sv_dat);
6522 I32 *pv = (I32*)SvPVX(sv_dat);
6524 for ( i = 0 ; i < count ; i++ ) {
6525 if ( pv[i] == RExC_npar ) {
6531 pv = (I32*)SvGROW(sv_dat, SvCUR(sv_dat) + sizeof(I32)+1);
6532 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
6533 pv[count] = RExC_npar;
6534 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
6537 (void)SvUPGRADE(sv_dat,SVt_PVNV);
6538 sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
6540 SvIV_set(sv_dat, 1);
6543 if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
6544 SvREFCNT_dec(svname);
6547 /*sv_dump(sv_dat);*/
6549 nextchar(pRExC_state);
6551 goto capturing_parens;
6553 RExC_seen |= REG_SEEN_LOOKBEHIND;
6554 RExC_in_lookbehind++;
6556 case '=': /* (?=...) */
6557 RExC_seen_zerolen++;
6559 case '!': /* (?!...) */
6560 RExC_seen_zerolen++;
6561 if (*RExC_parse == ')') {
6562 ret=reg_node(pRExC_state, OPFAIL);
6563 nextchar(pRExC_state);
6567 case '|': /* (?|...) */
6568 /* branch reset, behave like a (?:...) except that
6569 buffers in alternations share the same numbers */
6571 after_freeze = freeze_paren = RExC_npar;
6573 case ':': /* (?:...) */
6574 case '>': /* (?>...) */
6576 case '$': /* (?$...) */
6577 case '@': /* (?@...) */
6578 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
6580 case '#': /* (?#...) */
6581 while (*RExC_parse && *RExC_parse != ')')
6583 if (*RExC_parse != ')')
6584 FAIL("Sequence (?#... not terminated");
6585 nextchar(pRExC_state);
6588 case '0' : /* (?0) */
6589 case 'R' : /* (?R) */
6590 if (*RExC_parse != ')')
6591 FAIL("Sequence (?R) not terminated");
6592 ret = reg_node(pRExC_state, GOSTART);
6593 *flagp |= POSTPONED;
6594 nextchar(pRExC_state);
6597 { /* named and numeric backreferences */
6599 case '&': /* (?&NAME) */
6600 parse_start = RExC_parse - 1;
6603 SV *sv_dat = reg_scan_name(pRExC_state,
6604 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6605 num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
6607 goto gen_recurse_regop;
6610 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
6612 vFAIL("Illegal pattern");
6614 goto parse_recursion;
6616 case '-': /* (?-1) */
6617 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
6618 RExC_parse--; /* rewind to let it be handled later */
6622 case '1': case '2': case '3': case '4': /* (?1) */
6623 case '5': case '6': case '7': case '8': case '9':
6626 num = atoi(RExC_parse);
6627 parse_start = RExC_parse - 1; /* MJD */
6628 if (*RExC_parse == '-')
6630 while (isDIGIT(*RExC_parse))
6632 if (*RExC_parse!=')')
6633 vFAIL("Expecting close bracket");
6636 if ( paren == '-' ) {
6638 Diagram of capture buffer numbering.
6639 Top line is the normal capture buffer numbers
6640 Bottom line is the negative indexing as from
6644 /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
6648 num = RExC_npar + num;
6651 vFAIL("Reference to nonexistent group");
6653 } else if ( paren == '+' ) {
6654 num = RExC_npar + num - 1;
6657 ret = reganode(pRExC_state, GOSUB, num);
6659 if (num > (I32)RExC_rx->nparens) {
6661 vFAIL("Reference to nonexistent group");
6663 ARG2L_SET( ret, RExC_recurse_count++);
6665 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
6666 "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
6670 RExC_seen |= REG_SEEN_RECURSE;
6671 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
6672 Set_Node_Offset(ret, parse_start); /* MJD */
6674 *flagp |= POSTPONED;
6675 nextchar(pRExC_state);
6677 } /* named and numeric backreferences */
6680 case '?': /* (??...) */
6682 if (*RExC_parse != '{') {
6684 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
6687 *flagp |= POSTPONED;
6688 paren = *RExC_parse++;
6690 case '{': /* (?{...}) */
6695 char *s = RExC_parse;
6697 RExC_seen_zerolen++;
6698 RExC_seen |= REG_SEEN_EVAL;
6699 while (count && (c = *RExC_parse)) {
6710 if (*RExC_parse != ')') {
6712 vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
6716 OP_4tree *sop, *rop;
6717 SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
6720 Perl_save_re_context(aTHX);
6721 rop = Perl_sv_compile_2op_is_broken(aTHX_ sv, &sop, "re", &pad);
6722 sop->op_private |= OPpREFCOUNTED;
6723 /* re_dup will OpREFCNT_inc */
6724 OpREFCNT_set(sop, 1);
6727 n = add_data(pRExC_state, 3, "nop");
6728 RExC_rxi->data->data[n] = (void*)rop;
6729 RExC_rxi->data->data[n+1] = (void*)sop;
6730 RExC_rxi->data->data[n+2] = (void*)pad;
6733 else { /* First pass */
6734 if (PL_reginterp_cnt < ++RExC_seen_evals
6736 /* No compiled RE interpolated, has runtime
6737 components ===> unsafe. */
6738 FAIL("Eval-group not allowed at runtime, use re 'eval'");
6739 if (PL_tainting && PL_tainted)
6740 FAIL("Eval-group in insecure regular expression");
6741 #if PERL_VERSION > 8
6742 if (IN_PERL_COMPILETIME)
6747 nextchar(pRExC_state);
6749 ret = reg_node(pRExC_state, LOGICAL);
6752 REGTAIL(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
6753 /* deal with the length of this later - MJD */
6756 ret = reganode(pRExC_state, EVAL, n);
6757 Set_Node_Length(ret, RExC_parse - parse_start + 1);
6758 Set_Node_Offset(ret, parse_start);
6761 case '(': /* (?(?{...})...) and (?(?=...)...) */
6764 if (RExC_parse[0] == '?') { /* (?(?...)) */
6765 if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
6766 || RExC_parse[1] == '<'
6767 || RExC_parse[1] == '{') { /* Lookahead or eval. */
6770 ret = reg_node(pRExC_state, LOGICAL);
6773 REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
6777 else if ( RExC_parse[0] == '<' /* (?(<NAME>)...) */
6778 || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
6780 char ch = RExC_parse[0] == '<' ? '>' : '\'';
6781 char *name_start= RExC_parse++;
6783 SV *sv_dat=reg_scan_name(pRExC_state,
6784 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6785 if (RExC_parse == name_start || *RExC_parse != ch)
6786 vFAIL2("Sequence (?(%c... not terminated",
6787 (ch == '>' ? '<' : ch));
6790 num = add_data( pRExC_state, 1, "S" );
6791 RExC_rxi->data->data[num]=(void*)sv_dat;
6792 SvREFCNT_inc_simple_void(sv_dat);
6794 ret = reganode(pRExC_state,NGROUPP,num);
6795 goto insert_if_check_paren;
6797 else if (RExC_parse[0] == 'D' &&
6798 RExC_parse[1] == 'E' &&
6799 RExC_parse[2] == 'F' &&
6800 RExC_parse[3] == 'I' &&
6801 RExC_parse[4] == 'N' &&
6802 RExC_parse[5] == 'E')
6804 ret = reganode(pRExC_state,DEFINEP,0);
6807 goto insert_if_check_paren;
6809 else if (RExC_parse[0] == 'R') {
6812 if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
6813 parno = atoi(RExC_parse++);
6814 while (isDIGIT(*RExC_parse))
6816 } else if (RExC_parse[0] == '&') {
6819 sv_dat = reg_scan_name(pRExC_state,
6820 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6821 parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
6823 ret = reganode(pRExC_state,INSUBP,parno);
6824 goto insert_if_check_paren;
6826 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
6829 parno = atoi(RExC_parse++);
6831 while (isDIGIT(*RExC_parse))
6833 ret = reganode(pRExC_state, GROUPP, parno);
6835 insert_if_check_paren:
6836 if ((c = *nextchar(pRExC_state)) != ')')
6837 vFAIL("Switch condition not recognized");
6839 REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
6840 br = regbranch(pRExC_state, &flags, 1,depth+1);
6842 br = reganode(pRExC_state, LONGJMP, 0);
6844 REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
6845 c = *nextchar(pRExC_state);
6850 vFAIL("(?(DEFINE)....) does not allow branches");
6851 lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
6852 regbranch(pRExC_state, &flags, 1,depth+1);
6853 REGTAIL(pRExC_state, ret, lastbr);
6856 c = *nextchar(pRExC_state);
6861 vFAIL("Switch (?(condition)... contains too many branches");
6862 ender = reg_node(pRExC_state, TAIL);
6863 REGTAIL(pRExC_state, br, ender);
6865 REGTAIL(pRExC_state, lastbr, ender);
6866 REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
6869 REGTAIL(pRExC_state, ret, ender);
6870 RExC_size++; /* XXX WHY do we need this?!!
6871 For large programs it seems to be required
6872 but I can't figure out why. -- dmq*/
6876 vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
6880 RExC_parse--; /* for vFAIL to print correctly */
6881 vFAIL("Sequence (? incomplete");
6883 case DEFAULT_PAT_MOD: /* Use default flags with the exceptions
6885 has_use_defaults = TRUE;
6886 STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
6887 set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
6888 ? REGEX_UNICODE_CHARSET
6889 : REGEX_DEPENDS_CHARSET);
6893 parse_flags: /* (?i) */
6895 U32 posflags = 0, negflags = 0;
6896 U32 *flagsp = &posflags;
6897 bool has_charset_modifier = 0;
6898 regex_charset cs = REGEX_DEPENDS_CHARSET;
6900 while (*RExC_parse) {
6901 /* && strchr("iogcmsx", *RExC_parse) */
6902 /* (?g), (?gc) and (?o) are useless here
6903 and must be globally applied -- japhy */
6904 switch (*RExC_parse) {
6905 CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
6906 case LOCALE_PAT_MOD:
6907 if (has_charset_modifier || flagsp == &negflags) {
6908 goto fail_modifiers;
6910 cs = REGEX_LOCALE_CHARSET;
6911 has_charset_modifier = 1;
6913 case UNICODE_PAT_MOD:
6914 if (has_charset_modifier || flagsp == &negflags) {
6915 goto fail_modifiers;
6917 cs = REGEX_UNICODE_CHARSET;
6918 has_charset_modifier = 1;
6920 case ASCII_RESTRICT_PAT_MOD:
6921 if (has_charset_modifier || flagsp == &negflags) {
6922 goto fail_modifiers;
6924 cs = REGEX_ASCII_RESTRICTED_CHARSET;
6925 has_charset_modifier = 1;
6927 case DEPENDS_PAT_MOD:
6928 if (has_use_defaults
6929 || has_charset_modifier
6930 || flagsp == &negflags)
6932 goto fail_modifiers;
6935 /* The dual charset means unicode semantics if the
6936 * pattern (or target, not known until runtime) are
6937 * utf8, or something in the pattern indicates unicode
6939 cs = (RExC_utf8 || RExC_uni_semantics)
6940 ? REGEX_UNICODE_CHARSET
6941 : REGEX_DEPENDS_CHARSET;
6942 has_charset_modifier = 1;
6944 case ONCE_PAT_MOD: /* 'o' */
6945 case GLOBAL_PAT_MOD: /* 'g' */
6946 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
6947 const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
6948 if (! (wastedflags & wflagbit) ) {
6949 wastedflags |= wflagbit;
6952 "Useless (%s%c) - %suse /%c modifier",
6953 flagsp == &negflags ? "?-" : "?",
6955 flagsp == &negflags ? "don't " : "",
6962 case CONTINUE_PAT_MOD: /* 'c' */
6963 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
6964 if (! (wastedflags & WASTED_C) ) {
6965 wastedflags |= WASTED_GC;
6968 "Useless (%sc) - %suse /gc modifier",
6969 flagsp == &negflags ? "?-" : "?",
6970 flagsp == &negflags ? "don't " : ""
6975 case KEEPCOPY_PAT_MOD: /* 'p' */
6976 if (flagsp == &negflags) {
6978 ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
6980 *flagsp |= RXf_PMf_KEEPCOPY;
6984 /* A flag is a default iff it is following a minus, so
6985 * if there is a minus, it means will be trying to
6986 * re-specify a default which is an error */
6987 if (has_use_defaults || flagsp == &negflags) {
6990 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
6994 wastedflags = 0; /* reset so (?g-c) warns twice */
7000 RExC_flags |= posflags;
7001 RExC_flags &= ~negflags;
7002 set_regex_charset(&RExC_flags, cs);
7004 oregflags |= posflags;
7005 oregflags &= ~negflags;
7006 set_regex_charset(&oregflags, cs);
7008 nextchar(pRExC_state);
7019 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7024 }} /* one for the default block, one for the switch */
7031 ret = reganode(pRExC_state, OPEN, parno);
7034 RExC_nestroot = parno;
7035 if (RExC_seen & REG_SEEN_RECURSE
7036 && !RExC_open_parens[parno-1])
7038 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
7039 "Setting open paren #%"IVdf" to %d\n",
7040 (IV)parno, REG_NODE_NUM(ret)));
7041 RExC_open_parens[parno-1]= ret;
7044 Set_Node_Length(ret, 1); /* MJD */
7045 Set_Node_Offset(ret, RExC_parse); /* MJD */
7053 /* Pick up the branches, linking them together. */
7054 parse_start = RExC_parse; /* MJD */
7055 br = regbranch(pRExC_state, &flags, 1,depth+1);
7058 if (RExC_npar > after_freeze)
7059 after_freeze = RExC_npar;
7060 RExC_npar = freeze_paren;
7063 /* branch_len = (paren != 0); */
7067 if (*RExC_parse == '|') {
7068 if (!SIZE_ONLY && RExC_extralen) {
7069 reginsert(pRExC_state, BRANCHJ, br, depth+1);
7072 reginsert(pRExC_state, BRANCH, br, depth+1);
7073 Set_Node_Length(br, paren != 0);
7074 Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
7078 RExC_extralen += 1; /* For BRANCHJ-BRANCH. */
7080 else if (paren == ':') {
7081 *flagp |= flags&SIMPLE;
7083 if (is_open) { /* Starts with OPEN. */
7084 REGTAIL(pRExC_state, ret, br); /* OPEN -> first. */
7086 else if (paren != '?') /* Not Conditional */
7088 *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
7090 while (*RExC_parse == '|') {
7091 if (!SIZE_ONLY && RExC_extralen) {
7092 ender = reganode(pRExC_state, LONGJMP,0);
7093 REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
7096 RExC_extralen += 2; /* Account for LONGJMP. */
7097 nextchar(pRExC_state);
7099 if (RExC_npar > after_freeze)
7100 after_freeze = RExC_npar;
7101 RExC_npar = freeze_paren;
7103 br = regbranch(pRExC_state, &flags, 0, depth+1);
7107 REGTAIL(pRExC_state, lastbr, br); /* BRANCH -> BRANCH. */
7109 *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
7112 if (have_branch || paren != ':') {
7113 /* Make a closing node, and hook it on the end. */
7116 ender = reg_node(pRExC_state, TAIL);
7119 ender = reganode(pRExC_state, CLOSE, parno);
7120 if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
7121 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
7122 "Setting close paren #%"IVdf" to %d\n",
7123 (IV)parno, REG_NODE_NUM(ender)));
7124 RExC_close_parens[parno-1]= ender;
7125 if (RExC_nestroot == parno)
7128 Set_Node_Offset(ender,RExC_parse+1); /* MJD */
7129 Set_Node_Length(ender,1); /* MJD */
7135 *flagp &= ~HASWIDTH;
7138 ender = reg_node(pRExC_state, SUCCEED);
7141 ender = reg_node(pRExC_state, END);
7143 assert(!RExC_opend); /* there can only be one! */
7148 REGTAIL(pRExC_state, lastbr, ender);
7150 if (have_branch && !SIZE_ONLY) {
7152 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
7154 /* Hook the tails of the branches to the closing node. */
7155 for (br = ret; br; br = regnext(br)) {
7156 const U8 op = PL_regkind[OP(br)];
7158 REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
7160 else if (op == BRANCHJ) {
7161 REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
7169 static const char parens[] = "=!<,>";
7171 if (paren && (p = strchr(parens, paren))) {
7172 U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
7173 int flag = (p - parens) > 1;
7176 node = SUSPEND, flag = 0;
7177 reginsert(pRExC_state, node,ret, depth+1);
7178 Set_Node_Cur_Length(ret);
7179 Set_Node_Offset(ret, parse_start + 1);
7181 REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
7185 /* Check for proper termination. */
7187 RExC_flags = oregflags;
7188 if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
7189 RExC_parse = oregcomp_parse;
7190 vFAIL("Unmatched (");
7193 else if (!paren && RExC_parse < RExC_end) {
7194 if (*RExC_parse == ')') {
7196 vFAIL("Unmatched )");
7199 FAIL("Junk on end of regexp"); /* "Can't happen". */
7203 if (RExC_in_lookbehind) {
7204 RExC_in_lookbehind--;
7207 RExC_npar = after_freeze;
7212 - regbranch - one alternative of an | operator
7214 * Implements the concatenation operator.
7217 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
7220 register regnode *ret;
7221 register regnode *chain = NULL;
7222 register regnode *latest;
7223 I32 flags = 0, c = 0;
7224 GET_RE_DEBUG_FLAGS_DECL;
7226 PERL_ARGS_ASSERT_REGBRANCH;
7228 DEBUG_PARSE("brnc");
7233 if (!SIZE_ONLY && RExC_extralen)
7234 ret = reganode(pRExC_state, BRANCHJ,0);
7236 ret = reg_node(pRExC_state, BRANCH);
7237 Set_Node_Length(ret, 1);
7241 if (!first && SIZE_ONLY)
7242 RExC_extralen += 1; /* BRANCHJ */
7244 *flagp = WORST; /* Tentatively. */
7247 nextchar(pRExC_state);
7248 while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
7250 latest = regpiece(pRExC_state, &flags,depth+1);
7251 if (latest == NULL) {
7252 if (flags & TRYAGAIN)
7256 else if (ret == NULL)
7258 *flagp |= flags&(HASWIDTH|POSTPONED);
7259 if (chain == NULL) /* First piece. */
7260 *flagp |= flags&SPSTART;
7263 REGTAIL(pRExC_state, chain, latest);
7268 if (chain == NULL) { /* Loop ran zero times. */
7269 chain = reg_node(pRExC_state, NOTHING);
7274 *flagp |= flags&SIMPLE;
7281 - regpiece - something followed by possible [*+?]
7283 * Note that the branching code sequences used for ? and the general cases
7284 * of * and + are somewhat optimized: they use the same NOTHING node as
7285 * both the endmarker for their branch list and the body of the last branch.
7286 * It might seem that this node could be dispensed with entirely, but the
7287 * endmarker role is not redundant.
7290 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
7293 register regnode *ret;
7295 register char *next;
7297 const char * const origparse = RExC_parse;
7299 I32 max = REG_INFTY;
7301 const char *maxpos = NULL;
7302 GET_RE_DEBUG_FLAGS_DECL;
7304 PERL_ARGS_ASSERT_REGPIECE;
7306 DEBUG_PARSE("piec");
7308 ret = regatom(pRExC_state, &flags,depth+1);
7310 if (flags & TRYAGAIN)
7317 if (op == '{' && regcurly(RExC_parse)) {
7319 parse_start = RExC_parse; /* MJD */
7320 next = RExC_parse + 1;
7321 while (isDIGIT(*next) || *next == ',') {
7330 if (*next == '}') { /* got one */
7334 min = atoi(RExC_parse);
7338 maxpos = RExC_parse;
7340 if (!max && *maxpos != '0')
7341 max = REG_INFTY; /* meaning "infinity" */
7342 else if (max >= REG_INFTY)
7343 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
7345 nextchar(pRExC_state);
7348 if ((flags&SIMPLE)) {
7349 RExC_naughty += 2 + RExC_naughty / 2;
7350 reginsert(pRExC_state, CURLY, ret, depth+1);
7351 Set_Node_Offset(ret, parse_start+1); /* MJD */
7352 Set_Node_Cur_Length(ret);
7355 regnode * const w = reg_node(pRExC_state, WHILEM);
7358 REGTAIL(pRExC_state, ret, w);
7359 if (!SIZE_ONLY && RExC_extralen) {
7360 reginsert(pRExC_state, LONGJMP,ret, depth+1);
7361 reginsert(pRExC_state, NOTHING,ret, depth+1);
7362 NEXT_OFF(ret) = 3; /* Go over LONGJMP. */
7364 reginsert(pRExC_state, CURLYX,ret, depth+1);
7366 Set_Node_Offset(ret, parse_start+1);
7367 Set_Node_Length(ret,
7368 op == '{' ? (RExC_parse - parse_start) : 1);
7370 if (!SIZE_ONLY && RExC_extralen)
7371 NEXT_OFF(ret) = 3; /* Go over NOTHING to LONGJMP. */
7372 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
7374 RExC_whilem_seen++, RExC_extralen += 3;
7375 RExC_naughty += 4 + RExC_naughty; /* compound interest */
7384 vFAIL("Can't do {n,m} with n > m");
7386 ARG1_SET(ret, (U16)min);
7387 ARG2_SET(ret, (U16)max);
7399 #if 0 /* Now runtime fix should be reliable. */
7401 /* if this is reinstated, don't forget to put this back into perldiag:
7403 =item Regexp *+ operand could be empty at {#} in regex m/%s/
7405 (F) The part of the regexp subject to either the * or + quantifier
7406 could match an empty string. The {#} shows in the regular
7407 expression about where the problem was discovered.
7411 if (!(flags&HASWIDTH) && op != '?')
7412 vFAIL("Regexp *+ operand could be empty");
7415 parse_start = RExC_parse;
7416 nextchar(pRExC_state);
7418 *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
7420 if (op == '*' && (flags&SIMPLE)) {
7421 reginsert(pRExC_state, STAR, ret, depth+1);
7425 else if (op == '*') {
7429 else if (op == '+' && (flags&SIMPLE)) {
7430 reginsert(pRExC_state, PLUS, ret, depth+1);
7434 else if (op == '+') {
7438 else if (op == '?') {
7443 if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
7444 ckWARN3reg(RExC_parse,
7445 "%.*s matches null string many times",
7446 (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
7450 if (RExC_parse < RExC_end && *RExC_parse == '?') {
7451 nextchar(pRExC_state);
7452 reginsert(pRExC_state, MINMOD, ret, depth+1);
7453 REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
7455 #ifndef REG_ALLOW_MINMOD_SUSPEND
7458 if (RExC_parse < RExC_end && *RExC_parse == '+') {
7460 nextchar(pRExC_state);
7461 ender = reg_node(pRExC_state, SUCCEED);
7462 REGTAIL(pRExC_state, ret, ender);
7463 reginsert(pRExC_state, SUSPEND, ret, depth+1);
7465 ender = reg_node(pRExC_state, TAIL);
7466 REGTAIL(pRExC_state, ret, ender);
7470 if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
7472 vFAIL("Nested quantifiers");
7479 /* reg_namedseq(pRExC_state,UVp)
7481 This is expected to be called by a parser routine that has
7482 recognized '\N' and needs to handle the rest. RExC_parse is
7483 expected to point at the first char following the N at the time
7486 The \N may be inside (indicated by valuep not being NULL) or outside a
7489 \N may begin either a named sequence, or if outside a character class, mean
7490 to match a non-newline. For non single-quoted regexes, the tokenizer has
7491 attempted to decide which, and in the case of a named sequence converted it
7492 into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
7493 where c1... are the characters in the sequence. For single-quoted regexes,
7494 the tokenizer passes the \N sequence through unchanged; this code will not
7495 attempt to determine this nor expand those. The net effect is that if the
7496 beginning of the passed-in pattern isn't '{U+' or there is no '}', it
7497 signals that this \N occurrence means to match a non-newline.
7499 Only the \N{U+...} form should occur in a character class, for the same
7500 reason that '.' inside a character class means to just match a period: it
7501 just doesn't make sense.
7503 If valuep is non-null then it is assumed that we are parsing inside
7504 of a charclass definition and the first codepoint in the resolved
7505 string is returned via *valuep and the routine will return NULL.
7506 In this mode if a multichar string is returned from the charnames
7507 handler, a warning will be issued, and only the first char in the
7508 sequence will be examined. If the string returned is zero length
7509 then the value of *valuep is undefined and NON-NULL will
7510 be returned to indicate failure. (This will NOT be a valid pointer
7513 If valuep is null then it is assumed that we are parsing normal text and a
7514 new EXACT node is inserted into the program containing the resolved string,
7515 and a pointer to the new node is returned. But if the string is zero length
7516 a NOTHING node is emitted instead.
7518 On success RExC_parse is set to the char following the endbrace.
7519 Parsing failures will generate a fatal error via vFAIL(...)
7522 S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp)
7524 char * endbrace; /* '}' following the name */
7525 regnode *ret = NULL;
7527 char* parse_start = RExC_parse - 2; /* points to the '\N' */
7531 GET_RE_DEBUG_FLAGS_DECL;
7533 PERL_ARGS_ASSERT_REG_NAMEDSEQ;
7537 /* The [^\n] meaning of \N ignores spaces and comments under the /x
7538 * modifier. The other meaning does not */
7539 p = (RExC_flags & RXf_PMf_EXTENDED)
7540 ? regwhite( pRExC_state, RExC_parse )
7543 /* Disambiguate between \N meaning a named character versus \N meaning
7544 * [^\n]. The former is assumed when it can't be the latter. */
7545 if (*p != '{' || regcurly(p)) {
7548 /* no bare \N in a charclass */
7549 vFAIL("\\N in a character class must be a named character: \\N{...}");
7551 nextchar(pRExC_state);
7552 ret = reg_node(pRExC_state, REG_ANY);
7553 *flagp |= HASWIDTH|SIMPLE;
7556 Set_Node_Length(ret, 1); /* MJD */
7560 /* Here, we have decided it should be a named sequence */
7562 /* The test above made sure that the next real character is a '{', but
7563 * under the /x modifier, it could be separated by space (or a comment and
7564 * \n) and this is not allowed (for consistency with \x{...} and the
7565 * tokenizer handling of \N{NAME}). */
7566 if (*RExC_parse != '{') {
7567 vFAIL("Missing braces on \\N{}");
7570 RExC_parse++; /* Skip past the '{' */
7572 if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */
7573 || ! (endbrace == RExC_parse /* nothing between the {} */
7574 || (endbrace - RExC_parse >= 2 /* U+ (bad hex is checked below */
7575 && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) */
7577 if (endbrace) RExC_parse = endbrace; /* position msg's '<--HERE' */
7578 vFAIL("\\N{NAME} must be resolved by the lexer");
7581 if (endbrace == RExC_parse) { /* empty: \N{} */
7583 RExC_parse = endbrace + 1;
7584 return reg_node(pRExC_state,NOTHING);
7588 ckWARNreg(RExC_parse,
7589 "Ignoring zero length \\N{} in character class"
7591 RExC_parse = endbrace + 1;
7594 return (regnode *) &RExC_parse; /* Invalid regnode pointer */
7597 REQUIRE_UTF8; /* named sequences imply Unicode semantics */
7598 RExC_parse += 2; /* Skip past the 'U+' */
7600 if (valuep) { /* In a bracketed char class */
7601 /* We only pay attention to the first char of
7602 multichar strings being returned. I kinda wonder
7603 if this makes sense as it does change the behaviour
7604 from earlier versions, OTOH that behaviour was broken
7605 as well. XXX Solution is to recharacterize as
7606 [rest-of-class]|multi1|multi2... */
7608 STRLEN length_of_hex;
7609 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
7610 | PERL_SCAN_DISALLOW_PREFIX
7611 | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
7613 char * endchar = RExC_parse + strcspn(RExC_parse, ".}");
7614 if (endchar < endbrace) {
7615 ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
7618 length_of_hex = (STRLEN)(endchar - RExC_parse);
7619 *valuep = grok_hex(RExC_parse, &length_of_hex, &flags, NULL);
7621 /* The tokenizer should have guaranteed validity, but it's possible to
7622 * bypass it by using single quoting, so check */
7623 if (length_of_hex == 0
7624 || length_of_hex != (STRLEN)(endchar - RExC_parse) )
7626 RExC_parse += length_of_hex; /* Includes all the valid */
7627 RExC_parse += (RExC_orig_utf8) /* point to after 1st invalid */
7628 ? UTF8SKIP(RExC_parse)
7630 /* Guard against malformed utf8 */
7631 if (RExC_parse >= endchar) RExC_parse = endchar;
7632 vFAIL("Invalid hexadecimal number in \\N{U+...}");
7635 RExC_parse = endbrace + 1;
7636 if (endchar == endbrace) return NULL;
7638 ret = (regnode *) &RExC_parse; /* Invalid regnode pointer */
7640 else { /* Not a char class */
7641 char *s; /* String to put in generated EXACT node */
7642 STRLEN len = 0; /* Its current byte length */
7643 char *endchar; /* Points to '.' or '}' ending cur char in the input
7646 ret = reg_node(pRExC_state, (U8) ((! FOLD) ? EXACT
7654 /* Exact nodes can hold only a U8 length's of text = 255. Loop through
7655 * the input which is of the form now 'c1.c2.c3...}' until find the
7656 * ending brace or exceed length 255. The characters that exceed this
7657 * limit are dropped. The limit could be relaxed should it become
7658 * desirable by reparsing this as (?:\N{NAME}), so could generate
7659 * multiple EXACT nodes, as is done for just regular input. But this
7660 * is primarily a named character, and not intended to be a huge long
7661 * string, so 255 bytes should be good enough */
7663 STRLEN length_of_hex;
7664 I32 grok_flags = PERL_SCAN_ALLOW_UNDERSCORES
7665 | PERL_SCAN_DISALLOW_PREFIX
7666 | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
7667 UV cp; /* Ord of current character */
7669 /* Code points are separated by dots. If none, there is only one
7670 * code point, and is terminated by the brace */
7671 endchar = RExC_parse + strcspn(RExC_parse, ".}");
7673 /* The values are Unicode even on EBCDIC machines */
7674 length_of_hex = (STRLEN)(endchar - RExC_parse);
7675 cp = grok_hex(RExC_parse, &length_of_hex, &grok_flags, NULL);
7676 if ( length_of_hex == 0
7677 || length_of_hex != (STRLEN)(endchar - RExC_parse) )
7679 RExC_parse += length_of_hex; /* Includes all the valid */
7680 RExC_parse += (RExC_orig_utf8) /* point to after 1st invalid */
7681 ? UTF8SKIP(RExC_parse)
7683 /* Guard against malformed utf8 */
7684 if (RExC_parse >= endchar) RExC_parse = endchar;
7685 vFAIL("Invalid hexadecimal number in \\N{U+...}");
7688 if (! FOLD) { /* Not folding, just append to the string */
7691 /* Quit before adding this character if would exceed limit */
7692 if (len + UNISKIP(cp) > U8_MAX) break;
7694 unilen = reguni(pRExC_state, cp, s);
7699 } else { /* Folding, output the folded equivalent */
7700 STRLEN foldlen,numlen;
7701 U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
7702 cp = toFOLD_uni(cp, tmpbuf, &foldlen);
7704 /* Quit before exceeding size limit */
7705 if (len + foldlen > U8_MAX) break;
7707 for (foldbuf = tmpbuf;
7711 cp = utf8_to_uvchr(foldbuf, &numlen);
7713 const STRLEN unilen = reguni(pRExC_state, cp, s);
7716 /* In EBCDIC the numlen and unilen can differ. */
7718 if (numlen >= foldlen)
7722 break; /* "Can't happen." */
7726 /* Point to the beginning of the next character in the sequence. */
7727 RExC_parse = endchar + 1;
7729 /* Quit if no more characters */
7730 if (RExC_parse >= endbrace) break;
7735 if (RExC_parse < endbrace) {
7736 ckWARNreg(RExC_parse - 1,
7737 "Using just the first characters returned by \\N{}");
7740 RExC_size += STR_SZ(len);
7743 RExC_emit += STR_SZ(len);
7746 RExC_parse = endbrace + 1;
7748 *flagp |= HASWIDTH; /* Not SIMPLE, as that causes the engine to fail
7749 with malformed in t/re/pat_advanced.t */
7751 Set_Node_Cur_Length(ret); /* MJD */
7752 nextchar(pRExC_state);
7762 * It returns the code point in utf8 for the value in *encp.
7763 * value: a code value in the source encoding
7764 * encp: a pointer to an Encode object
7766 * If the result from Encode is not a single character,
7767 * it returns U+FFFD (Replacement character) and sets *encp to NULL.
7770 S_reg_recode(pTHX_ const char value, SV **encp)
7773 SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
7774 const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
7775 const STRLEN newlen = SvCUR(sv);
7776 UV uv = UNICODE_REPLACEMENT;
7778 PERL_ARGS_ASSERT_REG_RECODE;
7782 ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
7785 if (!newlen || numlen != newlen) {
7786 uv = UNICODE_REPLACEMENT;
7794 - regatom - the lowest level
7796 Try to identify anything special at the start of the pattern. If there
7797 is, then handle it as required. This may involve generating a single regop,
7798 such as for an assertion; or it may involve recursing, such as to
7799 handle a () structure.
7801 If the string doesn't start with something special then we gobble up
7802 as much literal text as we can.
7804 Once we have been able to handle whatever type of thing started the
7805 sequence, we return.
7807 Note: we have to be careful with escapes, as they can be both literal
7808 and special, and in the case of \10 and friends can either, depending
7809 on context. Specifically there are two separate switches for handling
7810 escape sequences, with the one for handling literal escapes requiring
7811 a dummy entry for all of the special escapes that are actually handled
7816 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
7819 register regnode *ret = NULL;
7821 char *parse_start = RExC_parse;
7823 GET_RE_DEBUG_FLAGS_DECL;
7824 DEBUG_PARSE("atom");
7825 *flagp = WORST; /* Tentatively. */
7827 PERL_ARGS_ASSERT_REGATOM;
7830 switch ((U8)*RExC_parse) {
7832 RExC_seen_zerolen++;
7833 nextchar(pRExC_state);
7834 if (RExC_flags & RXf_PMf_MULTILINE)
7835 ret = reg_node(pRExC_state, MBOL);
7836 else if (RExC_flags & RXf_PMf_SINGLELINE)
7837 ret = reg_node(pRExC_state, SBOL);
7839 ret = reg_node(pRExC_state, BOL);
7840 Set_Node_Length(ret, 1); /* MJD */
7843 nextchar(pRExC_state);
7845 RExC_seen_zerolen++;
7846 if (RExC_flags & RXf_PMf_MULTILINE)
7847 ret = reg_node(pRExC_state, MEOL);
7848 else if (RExC_flags & RXf_PMf_SINGLELINE)
7849 ret = reg_node(pRExC_state, SEOL);
7851 ret = reg_node(pRExC_state, EOL);
7852 Set_Node_Length(ret, 1); /* MJD */
7855 nextchar(pRExC_state);
7856 if (RExC_flags & RXf_PMf_SINGLELINE)
7857 ret = reg_node(pRExC_state, SANY);
7859 ret = reg_node(pRExC_state, REG_ANY);
7860 *flagp |= HASWIDTH|SIMPLE;
7862 Set_Node_Length(ret, 1); /* MJD */
7866 char * const oregcomp_parse = ++RExC_parse;
7867 ret = regclass(pRExC_state,depth+1);
7868 if (*RExC_parse != ']') {
7869 RExC_parse = oregcomp_parse;
7870 vFAIL("Unmatched [");
7872 nextchar(pRExC_state);
7873 *flagp |= HASWIDTH|SIMPLE;
7874 Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
7878 nextchar(pRExC_state);
7879 ret = reg(pRExC_state, 1, &flags,depth+1);
7881 if (flags & TRYAGAIN) {
7882 if (RExC_parse == RExC_end) {
7883 /* Make parent create an empty node if needed. */
7891 *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
7895 if (flags & TRYAGAIN) {
7899 vFAIL("Internal urp");
7900 /* Supposed to be caught earlier. */
7903 if (!regcurly(RExC_parse)) {
7912 vFAIL("Quantifier follows nothing");
7914 case LATIN_SMALL_LETTER_SHARP_S:
7915 case UTF8_TWO_BYTE_HI_nocast(LATIN_SMALL_LETTER_SHARP_S):
7916 case UTF8_TWO_BYTE_HI_nocast(IOTA_D_T):
7917 #if UTF8_TWO_BYTE_HI_nocast(UPSILON_D_T) != UTF8_TWO_BYTE_HI_nocast(IOTA_D_T)
7918 #error The beginning utf8 byte of IOTA_D_T and UPSILON_D_T unexpectedly differ. Other instances in this code should have the case statement below.
7919 case UTF8_TWO_BYTE_HI_nocast(UPSILON_D_T):
7924 len=0; /* silence a spurious compiler warning */
7925 if ((cp = what_len_TRICKYFOLD_safe(RExC_parse,RExC_end,UTF,len))) {
7926 *flagp |= HASWIDTH; /* could be SIMPLE too, but needs a handler in regexec.regrepeat */
7927 RExC_parse+=len-1; /* we get one from nextchar() as well. :-( */
7928 ret = reganode(pRExC_state, FOLDCHAR, cp);
7929 Set_Node_Length(ret, 1); /* MJD */
7930 nextchar(pRExC_state); /* kill whitespace under /x */
7938 This switch handles escape sequences that resolve to some kind
7939 of special regop and not to literal text. Escape sequnces that
7940 resolve to literal text are handled below in the switch marked
7943 Every entry in this switch *must* have a corresponding entry
7944 in the literal escape switch. However, the opposite is not
7945 required, as the default for this switch is to jump to the
7946 literal text handling code.
7948 switch ((U8)*++RExC_parse) {
7949 case LATIN_SMALL_LETTER_SHARP_S:
7950 case UTF8_TWO_BYTE_HI_nocast(LATIN_SMALL_LETTER_SHARP_S):
7951 case UTF8_TWO_BYTE_HI_nocast(IOTA_D_T):
7953 /* Special Escapes */
7955 RExC_seen_zerolen++;
7956 ret = reg_node(pRExC_state, SBOL);
7958 goto finish_meta_pat;
7960 ret = reg_node(pRExC_state, GPOS);
7961 RExC_seen |= REG_SEEN_GPOS;
7963 goto finish_meta_pat;
7965 RExC_seen_zerolen++;
7966 ret = reg_node(pRExC_state, KEEPS);
7968 /* XXX:dmq : disabling in-place substitution seems to
7969 * be necessary here to avoid cases of memory corruption, as
7970 * with: C<$_="x" x 80; s/x\K/y/> -- rgs
7972 RExC_seen |= REG_SEEN_LOOKBEHIND;
7973 goto finish_meta_pat;
7975 ret = reg_node(pRExC_state, SEOL);
7977 RExC_seen_zerolen++; /* Do not optimize RE away */
7978 goto finish_meta_pat;
7980 ret = reg_node(pRExC_state, EOS);
7982 RExC_seen_zerolen++; /* Do not optimize RE away */
7983 goto finish_meta_pat;
7985 ret = reg_node(pRExC_state, CANY);
7986 RExC_seen |= REG_SEEN_CANY;
7987 *flagp |= HASWIDTH|SIMPLE;
7988 goto finish_meta_pat;
7990 ret = reg_node(pRExC_state, CLUMP);
7992 goto finish_meta_pat;
7994 switch (get_regex_charset(RExC_flags)) {
7995 case REGEX_LOCALE_CHARSET:
7998 case REGEX_UNICODE_CHARSET:
8001 case REGEX_ASCII_RESTRICTED_CHARSET:
8004 case REGEX_DEPENDS_CHARSET:
8010 ret = reg_node(pRExC_state, op);
8011 *flagp |= HASWIDTH|SIMPLE;
8012 goto finish_meta_pat;
8014 switch (get_regex_charset(RExC_flags)) {
8015 case REGEX_LOCALE_CHARSET:
8018 case REGEX_UNICODE_CHARSET:
8021 case REGEX_ASCII_RESTRICTED_CHARSET:
8024 case REGEX_DEPENDS_CHARSET:
8030 ret = reg_node(pRExC_state, op);
8031 *flagp |= HASWIDTH|SIMPLE;
8032 goto finish_meta_pat;
8034 RExC_seen_zerolen++;
8035 RExC_seen |= REG_SEEN_LOOKBEHIND;
8036 switch (get_regex_charset(RExC_flags)) {
8037 case REGEX_LOCALE_CHARSET:
8040 case REGEX_UNICODE_CHARSET:
8043 case REGEX_ASCII_RESTRICTED_CHARSET:
8046 case REGEX_DEPENDS_CHARSET:
8052 ret = reg_node(pRExC_state, op);
8053 FLAGS(ret) = get_regex_charset(RExC_flags);
8055 goto finish_meta_pat;
8057 RExC_seen_zerolen++;
8058 RExC_seen |= REG_SEEN_LOOKBEHIND;
8059 switch (get_regex_charset(RExC_flags)) {
8060 case REGEX_LOCALE_CHARSET:
8063 case REGEX_UNICODE_CHARSET:
8066 case REGEX_ASCII_RESTRICTED_CHARSET:
8069 case REGEX_DEPENDS_CHARSET:
8075 ret = reg_node(pRExC_state, op);
8076 FLAGS(ret) = get_regex_charset(RExC_flags);
8078 goto finish_meta_pat;
8080 switch (get_regex_charset(RExC_flags)) {
8081 case REGEX_LOCALE_CHARSET:
8084 case REGEX_UNICODE_CHARSET:
8087 case REGEX_ASCII_RESTRICTED_CHARSET:
8090 case REGEX_DEPENDS_CHARSET:
8096 ret = reg_node(pRExC_state, op);
8097 *flagp |= HASWIDTH|SIMPLE;
8098 goto finish_meta_pat;
8100 switch (get_regex_charset(RExC_flags)) {
8101 case REGEX_LOCALE_CHARSET:
8104 case REGEX_UNICODE_CHARSET:
8107 case REGEX_ASCII_RESTRICTED_CHARSET:
8110 case REGEX_DEPENDS_CHARSET:
8116 ret = reg_node(pRExC_state, op);
8117 *flagp |= HASWIDTH|SIMPLE;
8118 goto finish_meta_pat;
8120 switch (get_regex_charset(RExC_flags)) {
8121 case REGEX_LOCALE_CHARSET:
8124 case REGEX_ASCII_RESTRICTED_CHARSET:
8127 case REGEX_DEPENDS_CHARSET: /* No difference between these */
8128 case REGEX_UNICODE_CHARSET:
8134 ret = reg_node(pRExC_state, op);
8135 *flagp |= HASWIDTH|SIMPLE;
8136 goto finish_meta_pat;
8138 switch (get_regex_charset(RExC_flags)) {
8139 case REGEX_LOCALE_CHARSET:
8142 case REGEX_ASCII_RESTRICTED_CHARSET:
8145 case REGEX_DEPENDS_CHARSET: /* No difference between these */
8146 case REGEX_UNICODE_CHARSET:
8152 ret = reg_node(pRExC_state, op);
8153 *flagp |= HASWIDTH|SIMPLE;
8154 goto finish_meta_pat;
8156 ret = reg_node(pRExC_state, LNBREAK);
8157 *flagp |= HASWIDTH|SIMPLE;
8158 goto finish_meta_pat;
8160 ret = reg_node(pRExC_state, HORIZWS);
8161 *flagp |= HASWIDTH|SIMPLE;
8162 goto finish_meta_pat;
8164 ret = reg_node(pRExC_state, NHORIZWS);
8165 *flagp |= HASWIDTH|SIMPLE;
8166 goto finish_meta_pat;
8168 ret = reg_node(pRExC_state, VERTWS);
8169 *flagp |= HASWIDTH|SIMPLE;
8170 goto finish_meta_pat;
8172 ret = reg_node(pRExC_state, NVERTWS);
8173 *flagp |= HASWIDTH|SIMPLE;
8175 nextchar(pRExC_state);
8176 Set_Node_Length(ret, 2); /* MJD */
8181 char* const oldregxend = RExC_end;
8183 char* parse_start = RExC_parse - 2;
8186 if (RExC_parse[1] == '{') {
8187 /* a lovely hack--pretend we saw [\pX] instead */
8188 RExC_end = strchr(RExC_parse, '}');
8190 const U8 c = (U8)*RExC_parse;
8192 RExC_end = oldregxend;
8193 vFAIL2("Missing right brace on \\%c{}", c);
8198 RExC_end = RExC_parse + 2;
8199 if (RExC_end > oldregxend)
8200 RExC_end = oldregxend;
8204 ret = regclass(pRExC_state,depth+1);
8206 RExC_end = oldregxend;
8209 Set_Node_Offset(ret, parse_start + 2);
8210 Set_Node_Cur_Length(ret);
8211 nextchar(pRExC_state);
8212 *flagp |= HASWIDTH|SIMPLE;
8216 /* Handle \N and \N{NAME} here and not below because it can be
8217 multicharacter. join_exact() will join them up later on.
8218 Also this makes sure that things like /\N{BLAH}+/ and
8219 \N{BLAH} being multi char Just Happen. dmq*/
8221 ret= reg_namedseq(pRExC_state, NULL, flagp);
8223 case 'k': /* Handle \k<NAME> and \k'NAME' */
8226 char ch= RExC_parse[1];
8227 if (ch != '<' && ch != '\'' && ch != '{') {
8229 vFAIL2("Sequence %.2s... not terminated",parse_start);
8231 /* this pretty much dupes the code for (?P=...) in reg(), if
8232 you change this make sure you change that */
8233 char* name_start = (RExC_parse += 2);
8235 SV *sv_dat = reg_scan_name(pRExC_state,
8236 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8237 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
8238 if (RExC_parse == name_start || *RExC_parse != ch)
8239 vFAIL2("Sequence %.3s... not terminated",parse_start);
8242 num = add_data( pRExC_state, 1, "S" );
8243 RExC_rxi->data->data[num]=(void*)sv_dat;
8244 SvREFCNT_inc_simple_void(sv_dat);
8248 ret = reganode(pRExC_state,
8251 : (AT_LEAST_UNI_SEMANTICS)
8259 /* override incorrect value set in reganode MJD */
8260 Set_Node_Offset(ret, parse_start+1);
8261 Set_Node_Cur_Length(ret); /* MJD */
8262 nextchar(pRExC_state);
8268 case '1': case '2': case '3': case '4':
8269 case '5': case '6': case '7': case '8': case '9':
8272 bool isg = *RExC_parse == 'g';
8277 if (*RExC_parse == '{') {
8281 if (*RExC_parse == '-') {
8285 if (hasbrace && !isDIGIT(*RExC_parse)) {
8286 if (isrel) RExC_parse--;
8288 goto parse_named_seq;
8290 num = atoi(RExC_parse);
8291 if (isg && num == 0)
8292 vFAIL("Reference to invalid group 0");
8294 num = RExC_npar - num;
8296 vFAIL("Reference to nonexistent or unclosed group");
8298 if (!isg && num > 9 && num >= RExC_npar)
8301 char * const parse_start = RExC_parse - 1; /* MJD */
8302 while (isDIGIT(*RExC_parse))
8304 if (parse_start == RExC_parse - 1)
8305 vFAIL("Unterminated \\g... pattern");
8307 if (*RExC_parse != '}')
8308 vFAIL("Unterminated \\g{...} pattern");
8312 if (num > (I32)RExC_rx->nparens)
8313 vFAIL("Reference to nonexistent group");
8316 ret = reganode(pRExC_state,
8319 : (AT_LEAST_UNI_SEMANTICS)
8327 /* override incorrect value set in reganode MJD */
8328 Set_Node_Offset(ret, parse_start+1);
8329 Set_Node_Cur_Length(ret); /* MJD */
8331 nextchar(pRExC_state);
8336 if (RExC_parse >= RExC_end)
8337 FAIL("Trailing \\");
8340 /* Do not generate "unrecognized" warnings here, we fall
8341 back into the quick-grab loop below */
8348 if (RExC_flags & RXf_PMf_EXTENDED) {
8349 if ( reg_skipcomment( pRExC_state ) )
8356 register STRLEN len;
8361 U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
8363 parse_start = RExC_parse - 1;
8369 ret = reg_node(pRExC_state,
8370 (U8) ((! FOLD) ? EXACT
8373 : (AT_LEAST_UNI_SEMANTICS)
8378 for (len = 0, p = RExC_parse - 1;
8379 len < 127 && p < RExC_end;
8382 char * const oldp = p;
8384 if (RExC_flags & RXf_PMf_EXTENDED)
8385 p = regwhite( pRExC_state, p );
8387 case LATIN_SMALL_LETTER_SHARP_S:
8388 case UTF8_TWO_BYTE_HI_nocast(LATIN_SMALL_LETTER_SHARP_S):
8389 case UTF8_TWO_BYTE_HI_nocast(IOTA_D_T):
8390 if (LOC || !FOLD || !is_TRICKYFOLD_safe(p,RExC_end,UTF))
8391 goto normal_default;
8401 /* Literal Escapes Switch
8403 This switch is meant to handle escape sequences that
8404 resolve to a literal character.
8406 Every escape sequence that represents something
8407 else, like an assertion or a char class, is handled
8408 in the switch marked 'Special Escapes' above in this
8409 routine, but also has an entry here as anything that
8410 isn't explicitly mentioned here will be treated as
8411 an unescaped equivalent literal.
8415 /* These are all the special escapes. */
8416 case LATIN_SMALL_LETTER_SHARP_S:
8417 case UTF8_TWO_BYTE_HI_nocast(LATIN_SMALL_LETTER_SHARP_S):
8418 case UTF8_TWO_BYTE_HI_nocast(IOTA_D_T):
8419 if (LOC || !FOLD || !is_TRICKYFOLD_safe(p,RExC_end,UTF))
8420 goto normal_default;
8421 case 'A': /* Start assertion */
8422 case 'b': case 'B': /* Word-boundary assertion*/
8423 case 'C': /* Single char !DANGEROUS! */
8424 case 'd': case 'D': /* digit class */
8425 case 'g': case 'G': /* generic-backref, pos assertion */
8426 case 'h': case 'H': /* HORIZWS */
8427 case 'k': case 'K': /* named backref, keep marker */
8428 case 'N': /* named char sequence */
8429 case 'p': case 'P': /* Unicode property */
8430 case 'R': /* LNBREAK */
8431 case 's': case 'S': /* space class */
8432 case 'v': case 'V': /* VERTWS */
8433 case 'w': case 'W': /* word class */
8434 case 'X': /* eXtended Unicode "combining character sequence" */
8435 case 'z': case 'Z': /* End of line/string assertion */
8439 /* Anything after here is an escape that resolves to a
8440 literal. (Except digits, which may or may not)
8459 ender = ASCII_TO_NATIVE('\033');
8463 ender = ASCII_TO_NATIVE('\007');
8468 STRLEN brace_len = len;
8470 const char* error_msg;
8472 bool valid = grok_bslash_o(p,
8479 RExC_parse = p; /* going to die anyway; point
8480 to exact spot of failure */
8487 if (PL_encoding && ender < 0x100) {
8488 goto recode_encoding;
8497 char* const e = strchr(p, '}');
8501 vFAIL("Missing right brace on \\x{}");
8504 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
8505 | PERL_SCAN_DISALLOW_PREFIX;
8506 STRLEN numlen = e - p - 1;
8507 ender = grok_hex(p + 1, &numlen, &flags, NULL);
8514 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
8516 ender = grok_hex(p, &numlen, &flags, NULL);
8519 if (PL_encoding && ender < 0x100)
8520 goto recode_encoding;
8524 ender = grok_bslash_c(*p++, SIZE_ONLY);
8526 case '0': case '1': case '2': case '3':case '4':
8527 case '5': case '6': case '7': case '8':case '9':
8529 (isDIGIT(p[1]) && atoi(p) >= RExC_npar))
8531 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
8533 ender = grok_oct(p, &numlen, &flags, NULL);
8543 if (PL_encoding && ender < 0x100)
8544 goto recode_encoding;
8548 SV* enc = PL_encoding;
8549 ender = reg_recode((const char)(U8)ender, &enc);
8550 if (!enc && SIZE_ONLY)
8551 ckWARNreg(p, "Invalid escape in the specified encoding");
8557 FAIL("Trailing \\");
8560 if (!SIZE_ONLY&& isALPHA(*p))
8561 ckWARN2reg(p + 1, "Unrecognized escape \\%c passed through", UCHARAT(p));
8562 goto normal_default;
8567 if (UTF8_IS_START(*p) && UTF) {
8569 ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
8570 &numlen, UTF8_ALLOW_DEFAULT);
8577 if ( RExC_flags & RXf_PMf_EXTENDED)
8578 p = regwhite( pRExC_state, p );
8580 /* Prime the casefolded buffer. */
8581 ender = toFOLD_uni(ender, tmpbuf, &foldlen);
8583 if (p < RExC_end && ISMULT2(p)) { /* Back off on ?+*. */
8588 /* Emit all the Unicode characters. */
8590 for (foldbuf = tmpbuf;
8592 foldlen -= numlen) {
8593 ender = utf8_to_uvchr(foldbuf, &numlen);
8595 const STRLEN unilen = reguni(pRExC_state, ender, s);
8598 /* In EBCDIC the numlen
8599 * and unilen can differ. */
8601 if (numlen >= foldlen)
8605 break; /* "Can't happen." */
8609 const STRLEN unilen = reguni(pRExC_state, ender, s);
8618 REGC((char)ender, s++);
8624 /* Emit all the Unicode characters. */
8626 for (foldbuf = tmpbuf;
8628 foldlen -= numlen) {
8629 ender = utf8_to_uvchr(foldbuf, &numlen);
8631 const STRLEN unilen = reguni(pRExC_state, ender, s);
8634 /* In EBCDIC the numlen
8635 * and unilen can differ. */
8637 if (numlen >= foldlen)
8645 const STRLEN unilen = reguni(pRExC_state, ender, s);
8654 REGC((char)ender, s++);
8658 Set_Node_Cur_Length(ret); /* MJD */
8659 nextchar(pRExC_state);
8661 /* len is STRLEN which is unsigned, need to copy to signed */
8664 vFAIL("Internal disaster");
8668 if (len == 1 && UNI_IS_INVARIANT(ender))
8672 RExC_size += STR_SZ(len);
8675 RExC_emit += STR_SZ(len);
8683 /* Jumped to when an unrecognized character set is encountered */
8685 Perl_croak(aTHX_ "panic: Unknown regex character set encoding: %u", get_regex_charset(RExC_flags));
8690 S_regwhite( RExC_state_t *pRExC_state, char *p )
8692 const char *e = RExC_end;
8694 PERL_ARGS_ASSERT_REGWHITE;
8699 else if (*p == '#') {
8708 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
8716 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
8717 Character classes ([:foo:]) can also be negated ([:^foo:]).
8718 Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
8719 Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
8720 but trigger failures because they are currently unimplemented. */
8722 #define POSIXCC_DONE(c) ((c) == ':')
8723 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
8724 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
8727 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
8730 I32 namedclass = OOB_NAMEDCLASS;
8732 PERL_ARGS_ASSERT_REGPPOSIXCC;
8734 if (value == '[' && RExC_parse + 1 < RExC_end &&
8735 /* I smell either [: or [= or [. -- POSIX has been here, right? */
8736 POSIXCC(UCHARAT(RExC_parse))) {
8737 const char c = UCHARAT(RExC_parse);
8738 char* const s = RExC_parse++;
8740 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
8742 if (RExC_parse == RExC_end)
8743 /* Grandfather lone [:, [=, [. */
8746 const char* const t = RExC_parse++; /* skip over the c */
8749 if (UCHARAT(RExC_parse) == ']') {
8750 const char *posixcc = s + 1;
8751 RExC_parse++; /* skip over the ending ] */
8754 const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
8755 const I32 skip = t - posixcc;
8757 /* Initially switch on the length of the name. */
8760 if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
8761 namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
8764 /* Names all of length 5. */
8765 /* alnum alpha ascii blank cntrl digit graph lower
8766 print punct space upper */
8767 /* Offset 4 gives the best switch position. */
8768 switch (posixcc[4]) {
8770 if (memEQ(posixcc, "alph", 4)) /* alpha */
8771 namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
8774 if (memEQ(posixcc, "spac", 4)) /* space */
8775 namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
8778 if (memEQ(posixcc, "grap", 4)) /* graph */
8779 namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
8782 if (memEQ(posixcc, "asci", 4)) /* ascii */
8783 namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
8786 if (memEQ(posixcc, "blan", 4)) /* blank */
8787 namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
8790 if (memEQ(posixcc, "cntr", 4)) /* cntrl */
8791 namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
8794 if (memEQ(posixcc, "alnu", 4)) /* alnum */
8795 namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
8798 if (memEQ(posixcc, "lowe", 4)) /* lower */
8799 namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
8800 else if (memEQ(posixcc, "uppe", 4)) /* upper */
8801 namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
8804 if (memEQ(posixcc, "digi", 4)) /* digit */
8805 namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
8806 else if (memEQ(posixcc, "prin", 4)) /* print */
8807 namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
8808 else if (memEQ(posixcc, "punc", 4)) /* punct */
8809 namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
8814 if (memEQ(posixcc, "xdigit", 6))
8815 namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
8819 if (namedclass == OOB_NAMEDCLASS)
8820 Simple_vFAIL3("POSIX class [:%.*s:] unknown",
8822 assert (posixcc[skip] == ':');
8823 assert (posixcc[skip+1] == ']');
8824 } else if (!SIZE_ONLY) {
8825 /* [[=foo=]] and [[.foo.]] are still future. */
8827 /* adjust RExC_parse so the warning shows after
8829 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
8831 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
8834 /* Maternal grandfather:
8835 * "[:" ending in ":" but not in ":]" */
8845 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
8849 PERL_ARGS_ASSERT_CHECKPOSIXCC;
8851 if (POSIXCC(UCHARAT(RExC_parse))) {
8852 const char *s = RExC_parse;
8853 const char c = *s++;
8857 if (*s && c == *s && s[1] == ']') {
8859 "POSIX syntax [%c %c] belongs inside character classes",
8862 /* [[=foo=]] and [[.foo.]] are still future. */
8863 if (POSIXCC_NOTYET(c)) {
8864 /* adjust RExC_parse so the error shows after
8866 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
8868 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
8874 /* No locale test, and always Unicode semantics */
8875 #define _C_C_T_NOLOC_(NAME,TEST,WORD) \
8877 for (value = 0; value < 256; value++) \
8879 stored += S_set_regclass_bit(aTHX_ pRExC_state, ret, (U8) value, &nonbitmap); \
8883 case ANYOF_N##NAME: \
8884 for (value = 0; value < 256; value++) \
8886 stored += S_set_regclass_bit(aTHX_ pRExC_state, ret, (U8) value, &nonbitmap); \
8891 /* Like the above, but there are differences if we are in uni-8-bit or not, so
8892 * there are two tests passed in, to use depending on that. There aren't any
8893 * cases where the label is different from the name, so no need for that
8895 #define _C_C_T_(NAME, TEST_8, TEST_7, WORD) \
8897 if (LOC) ANYOF_CLASS_SET(ret, ANYOF_##NAME); \
8898 else if (UNI_SEMANTICS) { \
8899 for (value = 0; value < 256; value++) { \
8900 if (TEST_8(value)) stored += \
8901 S_set_regclass_bit(aTHX_ pRExC_state, ret, (U8) value, &nonbitmap); \
8905 for (value = 0; value < 128; value++) { \
8906 if (TEST_7(UNI_TO_NATIVE(value))) stored += \
8907 S_set_regclass_bit(aTHX_ pRExC_state, ret, \
8908 (U8) UNI_TO_NATIVE(value), &nonbitmap); \
8914 case ANYOF_N##NAME: \
8915 if (LOC) ANYOF_CLASS_SET(ret, ANYOF_N##NAME); \
8916 else if (UNI_SEMANTICS) { \
8917 for (value = 0; value < 256; value++) { \
8918 if (! TEST_8(value)) stored += \
8919 S_set_regclass_bit(aTHX_ pRExC_state, ret, (U8) value, &nonbitmap); \
8923 for (value = 0; value < 128; value++) { \
8924 if (! TEST_7(UNI_TO_NATIVE(value))) stored += S_set_regclass_bit( \
8925 aTHX_ pRExC_state, ret, (U8) UNI_TO_NATIVE(value), &nonbitmap); \
8927 if (ASCII_RESTRICTED) { \
8928 for (value = 128; value < 256; value++) { \
8929 stored += S_set_regclass_bit( \
8930 aTHX_ pRExC_state, ret, (U8) UNI_TO_NATIVE(value), &nonbitmap); \
8932 ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL|ANYOF_UTF8; \
8935 /* For a non-ut8 target string with DEPENDS semantics, all above \
8936 * ASCII Latin1 code points match the complement of any of the \
8937 * classes. But in utf8, they have their Unicode semantics, so \
8938 * can't just set them in the bitmap, or else regexec.c will think \
8939 * they matched when they shouldn't. */ \
8940 ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL|ANYOF_UTF8; \
8948 We dont use PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS as the direct test
8949 so that it is possible to override the option here without having to
8950 rebuild the entire core. as we are required to do if we change regcomp.h
8951 which is where PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS is defined.
8953 #if PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS
8954 #define BROKEN_UNICODE_CHARCLASS_MAPPINGS
8957 #ifdef BROKEN_UNICODE_CHARCLASS_MAPPINGS
8958 #define POSIX_CC_UNI_NAME(CCNAME) CCNAME
8960 #define POSIX_CC_UNI_NAME(CCNAME) "Posix" CCNAME
8964 S_set_regclass_bit_fold(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, HV** nonbitmap_ptr)
8967 /* Handle the setting of folds in the bitmap for non-locale ANYOF nodes.
8968 * Locale folding is done at run-time, so this function should not be
8969 * called for nodes that are for locales.
8971 * This function simply sets the bit corresponding to the fold of the input
8972 * 'value', if not already set. The fold of 'f' is 'F', and the fold of
8975 * It also sets any necessary flags, and returns the number of bits that
8976 * actually changed from 0 to 1 */
8981 fold = (AT_LEAST_UNI_SEMANTICS) ? PL_fold_latin1[value]
8984 /* It assumes the bit for 'value' has already been set */
8985 if (fold != value && ! ANYOF_BITMAP_TEST(node, fold)) {
8986 ANYOF_BITMAP_SET(node, fold);
8989 if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value)
8992 && PL_fold_latin1[value] != value))
8993 { /* A character that has a fold outside of Latin1 matches outside the
8994 bitmap, but only when the target string is utf8. Similarly when we
8995 don't have unicode semantics for the above ASCII Latin-1 characters,
8996 and they have a fold, they should match if the target is utf8, and
8998 if (! *nonbitmap_ptr) {
8999 *nonbitmap_ptr = _new_invlist(2);
9001 *nonbitmap_ptr = add_range_to_invlist(*nonbitmap_ptr, value, value);
9002 ANYOF_FLAGS(node) |= ANYOF_UTF8;
9009 PERL_STATIC_INLINE U8
9010 S_set_regclass_bit(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, HV** nonbitmap_ptr)
9012 /* This inline function sets a bit in the bitmap if not already set, and if
9013 * appropriate, its fold, returning the number of bits that actually
9014 * changed from 0 to 1 */
9018 if (ANYOF_BITMAP_TEST(node, value)) { /* Already set */
9022 ANYOF_BITMAP_SET(node, value);
9025 if (FOLD && ! LOC) { /* Locale folds aren't known until runtime */
9026 stored += S_set_regclass_bit_fold(aTHX_ pRExC_state, node, value, nonbitmap_ptr);
9033 parse a class specification and produce either an ANYOF node that
9034 matches the pattern or if the pattern matches a single char only and
9035 that char is < 256 and we are case insensitive then we produce an
9040 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
9043 register UV nextvalue;
9044 register IV prevvalue = OOB_UNICODE;
9045 register IV range = 0;
9046 UV value = 0; /* XXX:dmq: needs to be referenceable (unfortunately) */
9047 register regnode *ret;
9050 char *rangebegin = NULL;
9051 bool need_class = 0;
9054 HV* nonbitmap = NULL;
9055 AV* unicode_alternate = NULL;
9057 UV literal_endpoint = 0;
9059 UV stored = 0; /* how many chars stored in the bitmap */
9061 regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
9062 case we need to change the emitted regop to an EXACT. */
9063 const char * orig_parse = RExC_parse;
9064 GET_RE_DEBUG_FLAGS_DECL;
9066 PERL_ARGS_ASSERT_REGCLASS;
9068 PERL_UNUSED_ARG(depth);
9071 DEBUG_PARSE("clas");
9073 /* Assume we are going to generate an ANYOF node. */
9074 ret = reganode(pRExC_state, ANYOF, 0);
9078 ANYOF_FLAGS(ret) = 0;
9081 if (UCHARAT(RExC_parse) == '^') { /* Complement of range. */
9085 ANYOF_FLAGS(ret) |= ANYOF_INVERT;
9089 RExC_size += ANYOF_SKIP;
9090 #ifdef ANYOF_ADD_LOC_SKIP
9092 RExC_size += ANYOF_ADD_LOC_SKIP;
9095 listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
9098 RExC_emit += ANYOF_SKIP;
9100 ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
9101 #ifdef ANYOF_ADD_LOC_SKIP
9102 RExC_emit += ANYOF_ADD_LOC_SKIP;
9105 ANYOF_BITMAP_ZERO(ret);
9106 listsv = newSVpvs("# comment\n");
9109 nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
9111 if (!SIZE_ONLY && POSIXCC(nextvalue))
9112 checkposixcc(pRExC_state);
9114 /* allow 1st char to be ] (allowing it to be - is dealt with later) */
9115 if (UCHARAT(RExC_parse) == ']')
9119 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
9123 namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
9126 rangebegin = RExC_parse;
9128 value = utf8n_to_uvchr((U8*)RExC_parse,
9129 RExC_end - RExC_parse,
9130 &numlen, UTF8_ALLOW_DEFAULT);
9131 RExC_parse += numlen;
9134 value = UCHARAT(RExC_parse++);
9136 nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
9137 if (value == '[' && POSIXCC(nextvalue))
9138 namedclass = regpposixcc(pRExC_state, value);
9139 else if (value == '\\') {
9141 value = utf8n_to_uvchr((U8*)RExC_parse,
9142 RExC_end - RExC_parse,
9143 &numlen, UTF8_ALLOW_DEFAULT);
9144 RExC_parse += numlen;
9147 value = UCHARAT(RExC_parse++);
9148 /* Some compilers cannot handle switching on 64-bit integer
9149 * values, therefore value cannot be an UV. Yes, this will
9150 * be a problem later if we want switch on Unicode.
9151 * A similar issue a little bit later when switching on
9152 * namedclass. --jhi */
9153 switch ((I32)value) {
9154 case 'w': namedclass = ANYOF_ALNUM; break;
9155 case 'W': namedclass = ANYOF_NALNUM; break;
9156 case 's': namedclass = ANYOF_SPACE; break;
9157 case 'S': namedclass = ANYOF_NSPACE; break;
9158 case 'd': namedclass = ANYOF_DIGIT; break;
9159 case 'D': namedclass = ANYOF_NDIGIT; break;
9160 case 'v': namedclass = ANYOF_VERTWS; break;
9161 case 'V': namedclass = ANYOF_NVERTWS; break;
9162 case 'h': namedclass = ANYOF_HORIZWS; break;
9163 case 'H': namedclass = ANYOF_NHORIZWS; break;
9164 case 'N': /* Handle \N{NAME} in class */
9166 /* We only pay attention to the first char of
9167 multichar strings being returned. I kinda wonder
9168 if this makes sense as it does change the behaviour
9169 from earlier versions, OTOH that behaviour was broken
9171 UV v; /* value is register so we cant & it /grrr */
9172 if (reg_namedseq(pRExC_state, &v, NULL)) {
9182 if (RExC_parse >= RExC_end)
9183 vFAIL2("Empty \\%c{}", (U8)value);
9184 if (*RExC_parse == '{') {
9185 const U8 c = (U8)value;
9186 e = strchr(RExC_parse++, '}');
9188 vFAIL2("Missing right brace on \\%c{}", c);
9189 while (isSPACE(UCHARAT(RExC_parse)))
9191 if (e == RExC_parse)
9192 vFAIL2("Empty \\%c{}", c);
9194 while (isSPACE(UCHARAT(RExC_parse + n - 1)))
9203 ckWARN2reg(RExC_parse,
9204 "\\%c uses Unicode rules, not locale rules",
9209 if (UCHARAT(RExC_parse) == '^') {
9212 value = value == 'p' ? 'P' : 'p'; /* toggle */
9213 while (isSPACE(UCHARAT(RExC_parse))) {
9219 /* Add the property name to the list. If /i matching, give
9220 * a different name which consists of the normal name
9221 * sandwiched between two underscores and '_i'. The design
9222 * is discussed in the commit message for this. */
9223 Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s%.*s%s\n",
9224 (value=='p' ? '+' : '!'),
9233 /* The \p could match something in the Latin1 range, hence
9234 * something that isn't utf8 */
9235 ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP;
9236 namedclass = ANYOF_MAX; /* no official name, but it's named */
9238 /* \p means they want Unicode semantics */
9239 RExC_uni_semantics = 1;
9242 case 'n': value = '\n'; break;
9243 case 'r': value = '\r'; break;
9244 case 't': value = '\t'; break;
9245 case 'f': value = '\f'; break;
9246 case 'b': value = '\b'; break;
9247 case 'e': value = ASCII_TO_NATIVE('\033');break;
9248 case 'a': value = ASCII_TO_NATIVE('\007');break;
9250 RExC_parse--; /* function expects to be pointed at the 'o' */
9252 const char* error_msg;
9253 bool valid = grok_bslash_o(RExC_parse,
9258 RExC_parse += numlen;
9263 if (PL_encoding && value < 0x100) {
9264 goto recode_encoding;
9268 if (*RExC_parse == '{') {
9269 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
9270 | PERL_SCAN_DISALLOW_PREFIX;
9271 char * const e = strchr(RExC_parse++, '}');
9273 vFAIL("Missing right brace on \\x{}");
9275 numlen = e - RExC_parse;
9276 value = grok_hex(RExC_parse, &numlen, &flags, NULL);
9280 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
9282 value = grok_hex(RExC_parse, &numlen, &flags, NULL);
9283 RExC_parse += numlen;
9285 if (PL_encoding && value < 0x100)
9286 goto recode_encoding;
9289 value = grok_bslash_c(*RExC_parse++, SIZE_ONLY);
9291 case '0': case '1': case '2': case '3': case '4':
9292 case '5': case '6': case '7':
9294 /* Take 1-3 octal digits */
9295 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
9297 value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
9298 RExC_parse += numlen;
9299 if (PL_encoding && value < 0x100)
9300 goto recode_encoding;
9305 SV* enc = PL_encoding;
9306 value = reg_recode((const char)(U8)value, &enc);
9307 if (!enc && SIZE_ONLY)
9308 ckWARNreg(RExC_parse,
9309 "Invalid escape in the specified encoding");
9313 /* Allow \_ to not give an error */
9314 if (!SIZE_ONLY && isALNUM(value) && value != '_') {
9315 ckWARN2reg(RExC_parse,
9316 "Unrecognized escape \\%c in character class passed through",
9321 } /* end of \blah */
9327 if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
9329 /* What matches in a locale is not known until runtime, so need to
9330 * (one time per class) allocate extra space to pass to regexec.
9331 * The space will contain a bit for each named class that is to be
9332 * matched against. This isn't needed for \p{} and pseudo-classes,
9333 * as they are not affected by locale, and hence are dealt with
9335 if (LOC && namedclass < ANYOF_MAX && ! need_class) {
9338 #ifdef ANYOF_CLASS_ADD_SKIP
9339 RExC_size += ANYOF_CLASS_ADD_SKIP;
9343 #ifdef ANYOF_CLASS_ADD_SKIP
9344 RExC_emit += ANYOF_CLASS_ADD_SKIP;
9346 ANYOF_CLASS_ZERO(ret);
9348 ANYOF_FLAGS(ret) |= ANYOF_CLASS;
9351 /* a bad range like a-\d, a-[:digit:]. The '-' is taken as a
9356 RExC_parse >= rangebegin ?
9357 RExC_parse - rangebegin : 0;
9358 ckWARN4reg(RExC_parse,
9359 "False [] range \"%*.*s\"",
9362 if (prevvalue < 256) {
9364 S_set_regclass_bit(aTHX_ pRExC_state, ret, (U8) prevvalue, &nonbitmap);
9366 S_set_regclass_bit(aTHX_ pRExC_state, ret, '-', &nonbitmap);
9369 ANYOF_FLAGS(ret) |= ANYOF_UTF8;
9370 Perl_sv_catpvf(aTHX_ listsv,
9371 "%04"UVxf"\n%04"UVxf"\n", (UV)prevvalue, (UV) '-');
9375 range = 0; /* this was not a true range */
9381 const char *what = NULL;
9384 /* Possible truncation here but in some 64-bit environments
9385 * the compiler gets heartburn about switch on 64-bit values.
9386 * A similar issue a little earlier when switching on value.
9388 switch ((I32)namedclass) {
9390 case _C_C_T_(ALNUMC, isALNUMC_L1, isALNUMC, "XPosixAlnum");
9391 case _C_C_T_(ALPHA, isALPHA_L1, isALPHA, "XPosixAlpha");
9392 case _C_C_T_(BLANK, isBLANK_L1, isBLANK, "XPosixBlank");
9393 case _C_C_T_(CNTRL, isCNTRL_L1, isCNTRL, "XPosixCntrl");
9394 case _C_C_T_(GRAPH, isGRAPH_L1, isGRAPH, "XPosixGraph");
9395 case _C_C_T_(LOWER, isLOWER_L1, isLOWER, "XPosixLower");
9396 case _C_C_T_(PRINT, isPRINT_L1, isPRINT, "XPosixPrint");
9397 case _C_C_T_(PSXSPC, isPSXSPC_L1, isPSXSPC, "XPosixSpace");
9398 case _C_C_T_(PUNCT, isPUNCT_L1, isPUNCT, "XPosixPunct");
9399 case _C_C_T_(UPPER, isUPPER_L1, isUPPER, "XPosixUpper");
9400 #ifdef BROKEN_UNICODE_CHARCLASS_MAPPINGS
9401 /* \s, \w match all unicode if utf8. */
9402 case _C_C_T_(SPACE, isSPACE_L1, isSPACE, "SpacePerl");
9403 case _C_C_T_(ALNUM, isWORDCHAR_L1, isALNUM, "Word");
9405 /* \s, \w match ascii and locale only */
9406 case _C_C_T_(SPACE, isSPACE_L1, isSPACE, "PerlSpace");
9407 case _C_C_T_(ALNUM, isWORDCHAR_L1, isALNUM, "PerlWord");
9409 case _C_C_T_(XDIGIT, isXDIGIT_L1, isXDIGIT, "XPosixXDigit");
9410 case _C_C_T_NOLOC_(VERTWS, is_VERTWS_latin1(&value), "VertSpace");
9411 case _C_C_T_NOLOC_(HORIZWS, is_HORIZWS_latin1(&value), "HorizSpace");
9414 ANYOF_CLASS_SET(ret, ANYOF_ASCII);
9416 for (value = 0; value < 128; value++)
9418 S_set_regclass_bit(aTHX_ pRExC_state, ret, (U8) ASCII_TO_NATIVE(value), &nonbitmap);
9421 what = NULL; /* Doesn't match outside ascii, so
9422 don't want to add +utf8:: */
9426 ANYOF_CLASS_SET(ret, ANYOF_NASCII);
9428 for (value = 128; value < 256; value++)
9430 S_set_regclass_bit(aTHX_ pRExC_state, ret, (U8) ASCII_TO_NATIVE(value), &nonbitmap);
9432 ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
9438 ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
9440 /* consecutive digits assumed */
9441 for (value = '0'; value <= '9'; value++)
9443 S_set_regclass_bit(aTHX_ pRExC_state, ret, (U8) value, &nonbitmap);
9446 what = POSIX_CC_UNI_NAME("Digit");
9450 ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
9452 /* consecutive digits assumed */
9453 for (value = 0; value < '0'; value++)
9455 S_set_regclass_bit(aTHX_ pRExC_state, ret, (U8) value, &nonbitmap);
9456 for (value = '9' + 1; value < 256; value++)
9458 S_set_regclass_bit(aTHX_ pRExC_state, ret, (U8) value, &nonbitmap);
9461 what = POSIX_CC_UNI_NAME("Digit");
9462 if (ASCII_RESTRICTED ) {
9463 ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
9467 /* this is to handle \p and \P */
9470 vFAIL("Invalid [::] class");
9473 if (what && ! (ASCII_RESTRICTED)) {
9474 /* Strings such as "+utf8::isWord\n" */
9475 Perl_sv_catpvf(aTHX_ listsv, "%cutf8::Is%s\n", yesno, what);
9476 ANYOF_FLAGS(ret) |= ANYOF_UTF8;
9481 } /* end of namedclass \blah */
9484 if (prevvalue > (IV)value) /* b-a */ {
9485 const int w = RExC_parse - rangebegin;
9486 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
9487 range = 0; /* not a valid range */
9491 prevvalue = value; /* save the beginning of the range */
9492 if (*RExC_parse == '-' && RExC_parse+1 < RExC_end &&
9493 RExC_parse[1] != ']') {
9496 /* a bad range like \w-, [:word:]- ? */
9497 if (namedclass > OOB_NAMEDCLASS) {
9498 if (ckWARN(WARN_REGEXP)) {
9500 RExC_parse >= rangebegin ?
9501 RExC_parse - rangebegin : 0;
9503 "False [] range \"%*.*s\"",
9508 S_set_regclass_bit(aTHX_ pRExC_state, ret, '-', &nonbitmap);
9510 range = 1; /* yeah, it's a range! */
9511 continue; /* but do it the next time */
9516 RExC_uni_semantics = 1;
9519 /* now is the next time */
9521 if (prevvalue < 256) {
9522 const IV ceilvalue = value < 256 ? value : 255;
9525 /* In EBCDIC [\x89-\x91] should include
9526 * the \x8e but [i-j] should not. */
9527 if (literal_endpoint == 2 &&
9528 ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
9529 (isUPPER(prevvalue) && isUPPER(ceilvalue))))
9531 if (isLOWER(prevvalue)) {
9532 for (i = prevvalue; i <= ceilvalue; i++)
9533 if (isLOWER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
9535 S_set_regclass_bit(aTHX_ pRExC_state, ret, (U8) i, &nonbitmap);
9538 for (i = prevvalue; i <= ceilvalue; i++)
9539 if (isUPPER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
9541 S_set_regclass_bit(aTHX_ pRExC_state, ret, (U8) i, &nonbitmap);
9547 for (i = prevvalue; i <= ceilvalue; i++) {
9548 stored += S_set_regclass_bit(aTHX_ pRExC_state, ret, (U8) i, &nonbitmap);
9552 const UV prevnatvalue = NATIVE_TO_UNI(prevvalue);
9553 const UV natvalue = NATIVE_TO_UNI(value);
9555 nonbitmap = _new_invlist(2);
9557 nonbitmap = add_range_to_invlist(nonbitmap, prevnatvalue, natvalue);
9558 ANYOF_FLAGS(ret) |= ANYOF_UTF8;
9562 /* If the code point requires utf8 to represent, and we are not
9563 * folding, it can't match unless the target is in utf8. Only
9564 * a few code points above 255 fold to below it, so XXX an
9565 * optimization would be to know which ones and set the flag
9567 ANYOF_FLAGS(ret) |= (FOLD || value < 256)
9570 if (prevnatvalue < natvalue) { /* '>' case is fatal error above */
9572 /* The \t sets the whole range */
9573 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
9574 prevnatvalue, natvalue);
9576 /* Currently, we don't look at every value in the range.
9577 * Therefore we have to assume the worst case: that if
9578 * folding, it will match more than one character. But in
9579 * lookbehind patterns, can only be single character
9580 * length, so disallow those folds */
9581 if (FOLD && ! RExC_in_lookbehind) {
9585 else if (prevnatvalue == natvalue) {
9586 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", natvalue);
9588 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
9590 const UV f = to_uni_fold(natvalue, foldbuf, &foldlen);
9592 #ifdef EBCDIC /* RD t/uni/fold ff and 6b */
9593 if (RExC_precomp[0] == ':' &&
9594 RExC_precomp[1] == '[' &&
9595 (f == 0xDF || f == 0x92)) {
9596 f = NATIVE_TO_UNI(f);
9599 /* If folding and foldable and a single
9600 * character, insert also the folded version
9601 * to the charclass. */
9603 #ifdef EBCDIC /* RD tunifold ligatures s,t fb05, fb06 */
9604 if ((RExC_precomp[0] == ':' &&
9605 RExC_precomp[1] == '[' &&
9607 (value == 0xFB05 || value == 0xFB06))) ?
9608 foldlen == ((STRLEN)UNISKIP(f) - 1) :
9609 foldlen == (STRLEN)UNISKIP(f) )
9611 if (foldlen == (STRLEN)UNISKIP(f))
9613 Perl_sv_catpvf(aTHX_ listsv,
9615 else if (! RExC_in_lookbehind) {
9616 /* Any multicharacter foldings
9617 * (disallowed in lookbehind patterns)
9618 * require the following transform:
9619 * [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst)
9620 * where E folds into "pq" and F folds
9621 * into "rst", all other characters
9622 * fold to single characters. We save
9623 * away these multicharacter foldings,
9624 * to be later saved as part of the
9625 * additional "s" data. */
9628 if (!unicode_alternate)
9629 unicode_alternate = newAV();
9630 sv = newSVpvn_utf8((char*)foldbuf, foldlen,
9632 av_push(unicode_alternate, sv);
9637 /* If folding and the value is one of the Greek
9638 * sigmas insert a few more sigmas to make the
9639 * folding rules of the sigmas to work right.
9640 * Note that not all the possible combinations
9641 * are handled here: some of them are handled
9642 * by the standard folding rules, and some of
9643 * them (literal or EXACTF cases) are handled
9644 * during runtime in regexec.c:S_find_byclass(). */
9645 if (value == UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) {
9646 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
9647 (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA);
9648 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
9649 (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
9651 else if (value == UNICODE_GREEK_CAPITAL_LETTER_SIGMA)
9652 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
9653 (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
9659 literal_endpoint = 0;
9663 range = 0; /* this range (if it was one) is done now */
9670 /****** !SIZE_ONLY AFTER HERE *********/
9672 /* Finish up the non-bitmap entries */
9674 UV* nonbitmap_array;
9677 /* If folding, we add to the list all characters that could fold to or
9678 * from the ones already on the list */
9680 HV* fold_intersection;
9683 /* This is a list of all the characters that participate in folds
9684 * (except marks, etc in multi-char folds */
9685 if (! PL_utf8_foldable) {
9686 SV* swash = swash_init("utf8", "Cased", &PL_sv_undef, 1, 0);
9687 PL_utf8_foldable = _swash_to_invlist(swash);
9690 /* This is a hash that for a particular fold gives all characters
9691 * that are involved in it */
9692 if (! PL_utf8_foldclosures) {
9694 /* If the folds haven't been read in, call a fold
9695 * function to force that */
9696 if (! PL_utf8_tofold) {
9697 U8 dummy[UTF8_MAXBYTES+1];
9699 to_utf8_fold((U8*) "A", dummy, &dummy_len);
9701 PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
9704 /* Only the characters in this class that participate in folds need
9705 * be checked. Get the intersection of this class and all the
9706 * possible characters that are foldable. This can quickly narrow
9707 * down a large class */
9708 fold_intersection = invlist_intersection(PL_utf8_foldable, nonbitmap);
9710 /* Now look at the foldable characters in this class individually */
9711 fold_list = invlist_array(fold_intersection);
9712 for (i = 0; i < invlist_len(fold_intersection); i++) {
9715 /* The next entry is the beginning of the range that is in the
9717 UV start = fold_list[i++];
9720 /* The next entry is the beginning of the next range, which
9721 * isn't in the class, so the end of the current range is one
9723 UV end = fold_list[i] - 1;
9725 /* Look at every character in the range */
9726 for (j = start; j <= end; j++) {
9729 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
9731 const UV f = to_uni_fold(j, foldbuf, &foldlen);
9733 if (foldlen > (STRLEN)UNISKIP(f)) {
9735 /* Any multicharacter foldings (disallowed in
9736 * lookbehind patterns) require the following
9737 * transform: [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst) where
9738 * E folds into "pq" and F folds into "rst", all other
9739 * characters fold to single characters. We save away
9740 * these multicharacter foldings, to be later saved as
9741 * part of the additional "s" data. */
9742 if (! RExC_in_lookbehind) {
9743 /* XXX Discard this fold if any are latin1 and LOC */
9746 if (!unicode_alternate) {
9747 unicode_alternate = newAV();
9749 sv = newSVpvn_utf8((char*)foldbuf, foldlen, TRUE);
9750 av_push(unicode_alternate, sv);
9752 /* This node is variable length */
9754 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
9757 else { /* Single character fold */
9760 /* Consider "k" =~ /[K]/i. The line above would have
9761 * just folded the 'k' to itself, and that isn't going
9762 * to match 'K'. So we look through the closure of
9763 * everything that folds to 'k'. That will find the
9764 * 'K'. Initialize the list, if necessary */
9766 /* The data structure is a hash with the keys every
9767 * character that is folded to, like 'k', and the
9768 * values each an array of everything that folds to its
9769 * key. e.g. [ 'k', 'K', KELVIN_SIGN ] */
9770 if ((listp = hv_fetch(PL_utf8_foldclosures,
9771 (char *) foldbuf, foldlen, FALSE)))
9773 AV* list = (AV*) *listp;
9775 for (k = 0; k <= av_len(list); k++) {
9776 SV** c_p = av_fetch(list, k, FALSE);
9779 Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
9783 if (c < 256 && AT_LEAST_UNI_SEMANTICS) {
9784 stored += S_set_regclass_bit(aTHX_ pRExC_state, ret, (U8) c, &nonbitmap);
9786 /* It may be that the code point is already
9787 * in this range or already in the bitmap,
9788 * XXX THink about LOC
9789 * in which case we need do nothing */
9790 else if ((c < start || c > end)
9792 || ! ANYOF_BITMAP_TEST(ret, c)))
9794 nonbitmap = add_range_to_invlist(nonbitmap, c, c);
9801 invlist_destroy(fold_intersection);
9802 } /* End of processing all the folds */
9804 /* Here have the full list of items to match that aren't in the
9805 * bitmap. Convert to the structure that the rest of the code is
9806 * expecting. XXX That rest of the code should convert to this
9808 nonbitmap_array = invlist_array(nonbitmap);
9809 for (i = 0; i < invlist_len(nonbitmap); i++) {
9811 /* The next entry is the beginning of the range that is in the
9813 UV start = nonbitmap_array[i++];
9815 /* The next entry is the beginning of the next range, which isn't
9816 * in the class, so the end of the current range is one less than
9818 UV end = nonbitmap_array[i] - 1;
9821 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", start);
9824 /* The \t sets the whole range */
9825 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
9830 invlist_destroy(nonbitmap);
9833 /* Optimize inverted simple patterns (e.g. [^a-z]). Note that we haven't
9834 * set the FOLD flag yet, so this this does optimize those. It doesn't
9835 * optimize locale. Doing so perhaps could be done as long as there is
9836 * nothing like \w in it; some thought also would have to be given to the
9837 * interaction with above 0x100 chars */
9838 if (! LOC && (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) {
9839 for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
9840 ANYOF_BITMAP(ret)[value] ^= 0xFF;
9841 stored = 256 - stored;
9843 /* The inversion means that everything above 255 is matched; and at the
9844 * same time we clear the invert flag */
9845 ANYOF_FLAGS(ret) = ANYOF_UTF8|ANYOF_UNICODE_ALL;
9851 /* This is the one character in the bitmap that needs special handling
9852 * under non-locale folding, as it folds to two characters 'ss'. This
9853 * happens if it is set and not inverting, or isn't set and are
9854 * inverting (disallowed in lookbehind patterns because they can't be
9855 * variable length) */
9857 && ! RExC_in_lookbehind
9858 && (cBOOL(ANYOF_BITMAP_TEST(ret, LATIN_SMALL_LETTER_SHARP_S))
9859 ^ cBOOL(ANYOF_FLAGS(ret) & ANYOF_INVERT)))
9861 OP(ret) = ANYOFV; /* Can match more than a single char */
9863 /* Under Unicode semantics), it can do this when the target string
9865 if (UNI_SEMANTICS) {
9866 ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
9869 if (!unicode_alternate) {
9870 unicode_alternate = newAV();
9872 sv = newSVpvn_utf8("ss", 2, TRUE);
9873 av_push(unicode_alternate, sv);
9876 /* Folding in the bitmap is taken care of above, but not for locale
9877 * (for which we have to wait to see what folding is in effect at
9878 * runtime), and for things not in the bitmap. Set run-time fold flag
9880 if ((LOC || (ANYOF_FLAGS(ret) & ANYOF_NONBITMAP))) {
9881 ANYOF_FLAGS(ret) |= ANYOF_LOC_NONBITMAP_FOLD;
9885 /* A single character class can be "optimized" into an EXACTish node.
9886 * Note that since we don't currently count how many characters there are
9887 * outside the bitmap, we are XXX missing optimization possibilities for
9888 * them. This optimization can't happen unless this is a truly single
9889 * character class, which means that it can't be an inversion into a
9890 * many-character class, and there must be no possibility of there being
9891 * things outside the bitmap. 'stored' (only) for locales doesn't include
9892 * \w, etc, so have to make a special test that they aren't present
9894 * Similarly A 2-character class of the very special form like [bB] can be
9895 * optimized into an EXACTFish node, but only for non-locales, and for
9896 * characters which only have the two folds; so things like 'fF' and 'Ii'
9897 * wouldn't work because they are part of the fold of 'LATIN SMALL LIGATURE
9899 if (! (ANYOF_FLAGS(ret) & (ANYOF_NONBITMAP|ANYOF_INVERT|ANYOF_UNICODE_ALL))
9900 && (((stored == 1 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
9901 || (! ANYOF_CLASS_TEST_ANY_SET(ret)))))
9902 || (stored == 2 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
9903 && (! _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value))
9904 /* If the latest code point has a fold whose
9905 * bit is set, it must be the only other one */
9906 && ((prevvalue = PL_fold_latin1[value]) != (IV)value)
9907 && ANYOF_BITMAP_TEST(ret, prevvalue)))))
9909 /* Note that the information needed to decide to do this optimization
9910 * is not currently available until the 2nd pass, and that the actually
9911 * used EXACTish node takes less space than the calculated ANYOF node,
9912 * and hence the amount of space calculated in the first pass is larger
9913 * than actually used, so this optimization doesn't gain us any space.
9914 * But an EXACT node is faster than an ANYOF node, and can be combined
9915 * with any adjacent EXACT nodes later by the optimizer for further
9916 * gains. The speed of executing an EXACTF is similar to an ANYOF
9917 * node, so the optimization advantage comes from the ability to join
9918 * it to adjacent EXACT nodes */
9920 const char * cur_parse= RExC_parse;
9922 RExC_emit = (regnode *)orig_emit;
9923 RExC_parse = (char *)orig_parse;
9927 /* A locale node with one point can be folded; all the other cases
9928 * with folding will have two points, since we calculate them above
9930 if (ANYOF_FLAGS(ret) & ANYOF_LOC_NONBITMAP_FOLD) {
9936 } /* else 2 chars in the bit map: the folds of each other */
9937 else if (AT_LEAST_UNI_SEMANTICS || !isASCII(value)) {
9939 /* To join adjacent nodes, they must be the exact EXACTish type.
9940 * Try to use the most likely type, by using EXACTFU if the regex
9941 * calls for them, or is required because the character is
9945 else { /* Otherwise, more likely to be EXACTF type */
9949 ret = reg_node(pRExC_state, op);
9950 RExC_parse = (char *)cur_parse;
9951 if (UTF && ! NATIVE_IS_INVARIANT(value)) {
9952 *STRING(ret)= UTF8_EIGHT_BIT_HI((U8) value);
9953 *(STRING(ret) + 1)= UTF8_EIGHT_BIT_LO((U8) value);
9955 RExC_emit += STR_SZ(2);
9958 *STRING(ret)= (char)value;
9960 RExC_emit += STR_SZ(1);
9962 SvREFCNT_dec(listsv);
9967 AV * const av = newAV();
9969 /* The 0th element stores the character class description
9970 * in its textual form: used later (regexec.c:Perl_regclass_swash())
9971 * to initialize the appropriate swash (which gets stored in
9972 * the 1st element), and also useful for dumping the regnode.
9973 * The 2nd element stores the multicharacter foldings,
9974 * used later (regexec.c:S_reginclass()). */
9975 av_store(av, 0, listsv);
9976 av_store(av, 1, NULL);
9977 av_store(av, 2, MUTABLE_SV(unicode_alternate));
9978 rv = newRV_noinc(MUTABLE_SV(av));
9979 n = add_data(pRExC_state, 1, "s");
9980 RExC_rxi->data->data[n] = (void*)rv;
9988 /* reg_skipcomment()
9990 Absorbs an /x style # comments from the input stream.
9991 Returns true if there is more text remaining in the stream.
9992 Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment
9993 terminates the pattern without including a newline.
9995 Note its the callers responsibility to ensure that we are
10001 S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state)
10005 PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
10007 while (RExC_parse < RExC_end)
10008 if (*RExC_parse++ == '\n') {
10013 /* we ran off the end of the pattern without ending
10014 the comment, so we have to add an \n when wrapping */
10015 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
10023 Advances the parse position, and optionally absorbs
10024 "whitespace" from the inputstream.
10026 Without /x "whitespace" means (?#...) style comments only,
10027 with /x this means (?#...) and # comments and whitespace proper.
10029 Returns the RExC_parse point from BEFORE the scan occurs.
10031 This is the /x friendly way of saying RExC_parse++.
10035 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
10037 char* const retval = RExC_parse++;
10039 PERL_ARGS_ASSERT_NEXTCHAR;
10042 if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
10043 RExC_parse[2] == '#') {
10044 while (*RExC_parse != ')') {
10045 if (RExC_parse == RExC_end)
10046 FAIL("Sequence (?#... not terminated");
10052 if (RExC_flags & RXf_PMf_EXTENDED) {
10053 if (isSPACE(*RExC_parse)) {
10057 else if (*RExC_parse == '#') {
10058 if ( reg_skipcomment( pRExC_state ) )
10067 - reg_node - emit a node
10069 STATIC regnode * /* Location. */
10070 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
10073 register regnode *ptr;
10074 regnode * const ret = RExC_emit;
10075 GET_RE_DEBUG_FLAGS_DECL;
10077 PERL_ARGS_ASSERT_REG_NODE;
10080 SIZE_ALIGN(RExC_size);
10084 if (RExC_emit >= RExC_emit_bound)
10085 Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d", op);
10087 NODE_ALIGN_FILL(ret);
10089 FILL_ADVANCE_NODE(ptr, op);
10090 #ifdef RE_TRACK_PATTERN_OFFSETS
10091 if (RExC_offsets) { /* MJD */
10092 MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n",
10093 "reg_node", __LINE__,
10095 (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
10096 ? "Overwriting end of array!\n" : "OK",
10097 (UV)(RExC_emit - RExC_emit_start),
10098 (UV)(RExC_parse - RExC_start),
10099 (UV)RExC_offsets[0]));
10100 Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
10108 - reganode - emit a node with an argument
10110 STATIC regnode * /* Location. */
10111 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
10114 register regnode *ptr;
10115 regnode * const ret = RExC_emit;
10116 GET_RE_DEBUG_FLAGS_DECL;
10118 PERL_ARGS_ASSERT_REGANODE;
10121 SIZE_ALIGN(RExC_size);
10126 assert(2==regarglen[op]+1);
10128 Anything larger than this has to allocate the extra amount.
10129 If we changed this to be:
10131 RExC_size += (1 + regarglen[op]);
10133 then it wouldn't matter. Its not clear what side effect
10134 might come from that so its not done so far.
10139 if (RExC_emit >= RExC_emit_bound)
10140 Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d", op);
10142 NODE_ALIGN_FILL(ret);
10144 FILL_ADVANCE_NODE_ARG(ptr, op, arg);
10145 #ifdef RE_TRACK_PATTERN_OFFSETS
10146 if (RExC_offsets) { /* MJD */
10147 MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
10151 (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ?
10152 "Overwriting end of array!\n" : "OK",
10153 (UV)(RExC_emit - RExC_emit_start),
10154 (UV)(RExC_parse - RExC_start),
10155 (UV)RExC_offsets[0]));
10156 Set_Cur_Node_Offset;
10164 - reguni - emit (if appropriate) a Unicode character
10167 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
10171 PERL_ARGS_ASSERT_REGUNI;
10173 return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
10177 - reginsert - insert an operator in front of already-emitted operand
10179 * Means relocating the operand.
10182 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
10185 register regnode *src;
10186 register regnode *dst;
10187 register regnode *place;
10188 const int offset = regarglen[(U8)op];
10189 const int size = NODE_STEP_REGNODE + offset;
10190 GET_RE_DEBUG_FLAGS_DECL;
10192 PERL_ARGS_ASSERT_REGINSERT;
10193 PERL_UNUSED_ARG(depth);
10194 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
10195 DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
10204 if (RExC_open_parens) {
10206 /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
10207 for ( paren=0 ; paren < RExC_npar ; paren++ ) {
10208 if ( RExC_open_parens[paren] >= opnd ) {
10209 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
10210 RExC_open_parens[paren] += size;
10212 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
10214 if ( RExC_close_parens[paren] >= opnd ) {
10215 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
10216 RExC_close_parens[paren] += size;
10218 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
10223 while (src > opnd) {
10224 StructCopy(--src, --dst, regnode);
10225 #ifdef RE_TRACK_PATTERN_OFFSETS
10226 if (RExC_offsets) { /* MJD 20010112 */
10227 MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
10231 (UV)(dst - RExC_emit_start) > RExC_offsets[0]
10232 ? "Overwriting end of array!\n" : "OK",
10233 (UV)(src - RExC_emit_start),
10234 (UV)(dst - RExC_emit_start),
10235 (UV)RExC_offsets[0]));
10236 Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
10237 Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
10243 place = opnd; /* Op node, where operand used to be. */
10244 #ifdef RE_TRACK_PATTERN_OFFSETS
10245 if (RExC_offsets) { /* MJD */
10246 MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
10250 (UV)(place - RExC_emit_start) > RExC_offsets[0]
10251 ? "Overwriting end of array!\n" : "OK",
10252 (UV)(place - RExC_emit_start),
10253 (UV)(RExC_parse - RExC_start),
10254 (UV)RExC_offsets[0]));
10255 Set_Node_Offset(place, RExC_parse);
10256 Set_Node_Length(place, 1);
10259 src = NEXTOPER(place);
10260 FILL_ADVANCE_NODE(place, op);
10261 Zero(src, offset, regnode);
10265 - regtail - set the next-pointer at the end of a node chain of p to val.
10266 - SEE ALSO: regtail_study
10268 /* TODO: All three parms should be const */
10270 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
10273 register regnode *scan;
10274 GET_RE_DEBUG_FLAGS_DECL;
10276 PERL_ARGS_ASSERT_REGTAIL;
10278 PERL_UNUSED_ARG(depth);
10284 /* Find last node. */
10287 regnode * const temp = regnext(scan);
10289 SV * const mysv=sv_newmortal();
10290 DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
10291 regprop(RExC_rx, mysv, scan);
10292 PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
10293 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
10294 (temp == NULL ? "->" : ""),
10295 (temp == NULL ? PL_reg_name[OP(val)] : "")
10303 if (reg_off_by_arg[OP(scan)]) {
10304 ARG_SET(scan, val - scan);
10307 NEXT_OFF(scan) = val - scan;
10313 - regtail_study - set the next-pointer at the end of a node chain of p to val.
10314 - Look for optimizable sequences at the same time.
10315 - currently only looks for EXACT chains.
10317 This is experimental code. The idea is to use this routine to perform
10318 in place optimizations on branches and groups as they are constructed,
10319 with the long term intention of removing optimization from study_chunk so
10320 that it is purely analytical.
10322 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
10323 to control which is which.
10326 /* TODO: All four parms should be const */
10329 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
10332 register regnode *scan;
10334 #ifdef EXPERIMENTAL_INPLACESCAN
10337 GET_RE_DEBUG_FLAGS_DECL;
10339 PERL_ARGS_ASSERT_REGTAIL_STUDY;
10345 /* Find last node. */
10349 regnode * const temp = regnext(scan);
10350 #ifdef EXPERIMENTAL_INPLACESCAN
10351 if (PL_regkind[OP(scan)] == EXACT)
10352 if (join_exact(pRExC_state,scan,&min,1,val,depth+1))
10356 switch (OP(scan)) {
10361 if( exact == PSEUDO )
10363 else if ( exact != OP(scan) )
10372 SV * const mysv=sv_newmortal();
10373 DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
10374 regprop(RExC_rx, mysv, scan);
10375 PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
10376 SvPV_nolen_const(mysv),
10377 REG_NODE_NUM(scan),
10378 PL_reg_name[exact]);
10385 SV * const mysv_val=sv_newmortal();
10386 DEBUG_PARSE_MSG("");
10387 regprop(RExC_rx, mysv_val, val);
10388 PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
10389 SvPV_nolen_const(mysv_val),
10390 (IV)REG_NODE_NUM(val),
10394 if (reg_off_by_arg[OP(scan)]) {
10395 ARG_SET(scan, val - scan);
10398 NEXT_OFF(scan) = val - scan;
10406 - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
10410 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
10416 for (bit=0; bit<32; bit++) {
10417 if (flags & (1<<bit)) {
10418 if ((1<<bit) & RXf_PMf_CHARSET) { /* Output separately, below */
10421 if (!set++ && lead)
10422 PerlIO_printf(Perl_debug_log, "%s",lead);
10423 PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
10426 if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
10427 if (!set++ && lead) {
10428 PerlIO_printf(Perl_debug_log, "%s",lead);
10431 case REGEX_UNICODE_CHARSET:
10432 PerlIO_printf(Perl_debug_log, "UNICODE");
10434 case REGEX_LOCALE_CHARSET:
10435 PerlIO_printf(Perl_debug_log, "LOCALE");
10437 case REGEX_ASCII_RESTRICTED_CHARSET:
10438 PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
10441 PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
10447 PerlIO_printf(Perl_debug_log, "\n");
10449 PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
10455 Perl_regdump(pTHX_ const regexp *r)
10459 SV * const sv = sv_newmortal();
10460 SV *dsv= sv_newmortal();
10461 RXi_GET_DECL(r,ri);
10462 GET_RE_DEBUG_FLAGS_DECL;
10464 PERL_ARGS_ASSERT_REGDUMP;
10466 (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
10468 /* Header fields of interest. */
10469 if (r->anchored_substr) {
10470 RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr),
10471 RE_SV_DUMPLEN(r->anchored_substr), 30);
10472 PerlIO_printf(Perl_debug_log,
10473 "anchored %s%s at %"IVdf" ",
10474 s, RE_SV_TAIL(r->anchored_substr),
10475 (IV)r->anchored_offset);
10476 } else if (r->anchored_utf8) {
10477 RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8),
10478 RE_SV_DUMPLEN(r->anchored_utf8), 30);
10479 PerlIO_printf(Perl_debug_log,
10480 "anchored utf8 %s%s at %"IVdf" ",
10481 s, RE_SV_TAIL(r->anchored_utf8),
10482 (IV)r->anchored_offset);
10484 if (r->float_substr) {
10485 RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr),
10486 RE_SV_DUMPLEN(r->float_substr), 30);
10487 PerlIO_printf(Perl_debug_log,
10488 "floating %s%s at %"IVdf"..%"UVuf" ",
10489 s, RE_SV_TAIL(r->float_substr),
10490 (IV)r->float_min_offset, (UV)r->float_max_offset);
10491 } else if (r->float_utf8) {
10492 RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8),
10493 RE_SV_DUMPLEN(r->float_utf8), 30);
10494 PerlIO_printf(Perl_debug_log,
10495 "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
10496 s, RE_SV_TAIL(r->float_utf8),
10497 (IV)r->float_min_offset, (UV)r->float_max_offset);
10499 if (r->check_substr || r->check_utf8)
10500 PerlIO_printf(Perl_debug_log,
10502 (r->check_substr == r->float_substr
10503 && r->check_utf8 == r->float_utf8
10504 ? "(checking floating" : "(checking anchored"));
10505 if (r->extflags & RXf_NOSCAN)
10506 PerlIO_printf(Perl_debug_log, " noscan");
10507 if (r->extflags & RXf_CHECK_ALL)
10508 PerlIO_printf(Perl_debug_log, " isall");
10509 if (r->check_substr || r->check_utf8)
10510 PerlIO_printf(Perl_debug_log, ") ");
10512 if (ri->regstclass) {
10513 regprop(r, sv, ri->regstclass);
10514 PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
10516 if (r->extflags & RXf_ANCH) {
10517 PerlIO_printf(Perl_debug_log, "anchored");
10518 if (r->extflags & RXf_ANCH_BOL)
10519 PerlIO_printf(Perl_debug_log, "(BOL)");
10520 if (r->extflags & RXf_ANCH_MBOL)
10521 PerlIO_printf(Perl_debug_log, "(MBOL)");
10522 if (r->extflags & RXf_ANCH_SBOL)
10523 PerlIO_printf(Perl_debug_log, "(SBOL)");
10524 if (r->extflags & RXf_ANCH_GPOS)
10525 PerlIO_printf(Perl_debug_log, "(GPOS)");
10526 PerlIO_putc(Perl_debug_log, ' ');
10528 if (r->extflags & RXf_GPOS_SEEN)
10529 PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
10530 if (r->intflags & PREGf_SKIP)
10531 PerlIO_printf(Perl_debug_log, "plus ");
10532 if (r->intflags & PREGf_IMPLICIT)
10533 PerlIO_printf(Perl_debug_log, "implicit ");
10534 PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
10535 if (r->extflags & RXf_EVAL_SEEN)
10536 PerlIO_printf(Perl_debug_log, "with eval ");
10537 PerlIO_printf(Perl_debug_log, "\n");
10538 DEBUG_FLAGS_r(regdump_extflags("r->extflags: ",r->extflags));
10540 PERL_ARGS_ASSERT_REGDUMP;
10541 PERL_UNUSED_CONTEXT;
10542 PERL_UNUSED_ARG(r);
10543 #endif /* DEBUGGING */
10547 - regprop - printable representation of opcode
10549 #define EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags) \
10552 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]); \
10553 if (flags & ANYOF_INVERT) \
10554 /*make sure the invert info is in each */ \
10555 sv_catpvs(sv, "^"); \
10561 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
10566 RXi_GET_DECL(prog,progi);
10567 GET_RE_DEBUG_FLAGS_DECL;
10569 PERL_ARGS_ASSERT_REGPROP;
10573 if (OP(o) > REGNODE_MAX) /* regnode.type is unsigned */
10574 /* It would be nice to FAIL() here, but this may be called from
10575 regexec.c, and it would be hard to supply pRExC_state. */
10576 Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
10577 sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
10579 k = PL_regkind[OP(o)];
10582 sv_catpvs(sv, " ");
10583 /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
10584 * is a crude hack but it may be the best for now since
10585 * we have no flag "this EXACTish node was UTF-8"
10587 pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
10588 PERL_PV_ESCAPE_UNI_DETECT |
10589 PERL_PV_ESCAPE_NONASCII |
10590 PERL_PV_PRETTY_ELLIPSES |
10591 PERL_PV_PRETTY_LTGT |
10592 PERL_PV_PRETTY_NOCLEAR
10594 } else if (k == TRIE) {
10595 /* print the details of the trie in dumpuntil instead, as
10596 * progi->data isn't available here */
10597 const char op = OP(o);
10598 const U32 n = ARG(o);
10599 const reg_ac_data * const ac = IS_TRIE_AC(op) ?
10600 (reg_ac_data *)progi->data->data[n] :
10602 const reg_trie_data * const trie
10603 = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
10605 Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
10606 DEBUG_TRIE_COMPILE_r(
10607 Perl_sv_catpvf(aTHX_ sv,
10608 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
10609 (UV)trie->startstate,
10610 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
10611 (UV)trie->wordcount,
10614 (UV)TRIE_CHARCOUNT(trie),
10615 (UV)trie->uniquecharcount
10618 if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
10620 int rangestart = -1;
10621 U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
10622 sv_catpvs(sv, "[");
10623 for (i = 0; i <= 256; i++) {
10624 if (i < 256 && BITMAP_TEST(bitmap,i)) {
10625 if (rangestart == -1)
10627 } else if (rangestart != -1) {
10628 if (i <= rangestart + 3)
10629 for (; rangestart < i; rangestart++)
10630 put_byte(sv, rangestart);
10632 put_byte(sv, rangestart);
10633 sv_catpvs(sv, "-");
10634 put_byte(sv, i - 1);
10639 sv_catpvs(sv, "]");
10642 } else if (k == CURLY) {
10643 if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
10644 Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
10645 Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
10647 else if (k == WHILEM && o->flags) /* Ordinal/of */
10648 Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
10649 else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
10650 Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */
10651 if ( RXp_PAREN_NAMES(prog) ) {
10652 if ( k != REF || (OP(o) < NREF)) {
10653 AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
10654 SV **name= av_fetch(list, ARG(o), 0 );
10656 Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
10659 AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]);
10660 SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
10661 I32 *nums=(I32*)SvPVX(sv_dat);
10662 SV **name= av_fetch(list, nums[0], 0 );
10665 for ( n=0; n<SvIVX(sv_dat); n++ ) {
10666 Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
10667 (n ? "," : ""), (IV)nums[n]);
10669 Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
10673 } else if (k == GOSUB)
10674 Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
10675 else if (k == VERB) {
10677 Perl_sv_catpvf(aTHX_ sv, ":%"SVf,
10678 SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
10679 } else if (k == LOGICAL)
10680 Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */
10681 else if (k == FOLDCHAR)
10682 Perl_sv_catpvf(aTHX_ sv, "[0x%"UVXf"]", PTR2UV(ARG(o)) );
10683 else if (k == ANYOF) {
10684 int i, rangestart = -1;
10685 const U8 flags = ANYOF_FLAGS(o);
10688 /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
10689 static const char * const anyofs[] = {
10722 if (flags & ANYOF_LOCALE)
10723 sv_catpvs(sv, "{loc}");
10724 if (flags & ANYOF_LOC_NONBITMAP_FOLD)
10725 sv_catpvs(sv, "{i}");
10726 Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
10727 if (flags & ANYOF_INVERT)
10728 sv_catpvs(sv, "^");
10730 /* output what the standard cp 0-255 bitmap matches */
10731 for (i = 0; i <= 256; i++) {
10732 if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
10733 if (rangestart == -1)
10735 } else if (rangestart != -1) {
10736 if (i <= rangestart + 3)
10737 for (; rangestart < i; rangestart++)
10738 put_byte(sv, rangestart);
10740 put_byte(sv, rangestart);
10741 sv_catpvs(sv, "-");
10742 put_byte(sv, i - 1);
10749 EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
10750 /* output any special charclass tests (used entirely under use locale) */
10751 if (ANYOF_CLASS_TEST_ANY_SET(o))
10752 for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
10753 if (ANYOF_CLASS_TEST(o,i)) {
10754 sv_catpv(sv, anyofs[i]);
10758 EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
10760 if (flags & ANYOF_NON_UTF8_LATIN1_ALL) {
10761 sv_catpvs(sv, "{non-utf8-latin1-all}");
10764 /* output information about the unicode matching */
10765 if (flags & ANYOF_UNICODE_ALL)
10766 sv_catpvs(sv, "{unicode_all}");
10767 else if (flags & ANYOF_UTF8)
10768 sv_catpvs(sv, "{unicode}");
10769 if (flags & ANYOF_NONBITMAP_NON_UTF8)
10770 sv_catpvs(sv, "{outside bitmap}");
10774 SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
10778 U8 s[UTF8_MAXBYTES_CASE+1];
10780 for (i = 0; i <= 256; i++) { /* just the first 256 */
10781 uvchr_to_utf8(s, i);
10783 if (i < 256 && swash_fetch(sw, s, TRUE)) {
10784 if (rangestart == -1)
10786 } else if (rangestart != -1) {
10787 if (i <= rangestart + 3)
10788 for (; rangestart < i; rangestart++) {
10789 const U8 * const e = uvchr_to_utf8(s,rangestart);
10791 for(p = s; p < e; p++)
10795 const U8 *e = uvchr_to_utf8(s,rangestart);
10797 for (p = s; p < e; p++)
10799 sv_catpvs(sv, "-");
10800 e = uvchr_to_utf8(s, i-1);
10801 for (p = s; p < e; p++)
10808 sv_catpvs(sv, "..."); /* et cetera */
10812 char *s = savesvpv(lv);
10813 char * const origs = s;
10815 while (*s && *s != '\n')
10819 const char * const t = ++s;
10837 Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
10839 else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
10840 Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
10842 PERL_UNUSED_CONTEXT;
10843 PERL_UNUSED_ARG(sv);
10844 PERL_UNUSED_ARG(o);
10845 PERL_UNUSED_ARG(prog);
10846 #endif /* DEBUGGING */
10850 Perl_re_intuit_string(pTHX_ REGEXP * const r)
10851 { /* Assume that RE_INTUIT is set */
10853 struct regexp *const prog = (struct regexp *)SvANY(r);
10854 GET_RE_DEBUG_FLAGS_DECL;
10856 PERL_ARGS_ASSERT_RE_INTUIT_STRING;
10857 PERL_UNUSED_CONTEXT;
10861 const char * const s = SvPV_nolen_const(prog->check_substr
10862 ? prog->check_substr : prog->check_utf8);
10864 if (!PL_colorset) reginitcolors();
10865 PerlIO_printf(Perl_debug_log,
10866 "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
10868 prog->check_substr ? "" : "utf8 ",
10869 PL_colors[5],PL_colors[0],
10872 (strlen(s) > 60 ? "..." : ""));
10875 return prog->check_substr ? prog->check_substr : prog->check_utf8;
10881 handles refcounting and freeing the perl core regexp structure. When
10882 it is necessary to actually free the structure the first thing it
10883 does is call the 'free' method of the regexp_engine associated to
10884 the regexp, allowing the handling of the void *pprivate; member
10885 first. (This routine is not overridable by extensions, which is why
10886 the extensions free is called first.)
10888 See regdupe and regdupe_internal if you change anything here.
10890 #ifndef PERL_IN_XSUB_RE
10892 Perl_pregfree(pTHX_ REGEXP *r)
10898 Perl_pregfree2(pTHX_ REGEXP *rx)
10901 struct regexp *const r = (struct regexp *)SvANY(rx);
10902 GET_RE_DEBUG_FLAGS_DECL;
10904 PERL_ARGS_ASSERT_PREGFREE2;
10906 if (r->mother_re) {
10907 ReREFCNT_dec(r->mother_re);
10909 CALLREGFREE_PVT(rx); /* free the private data */
10910 SvREFCNT_dec(RXp_PAREN_NAMES(r));
10913 SvREFCNT_dec(r->anchored_substr);
10914 SvREFCNT_dec(r->anchored_utf8);
10915 SvREFCNT_dec(r->float_substr);
10916 SvREFCNT_dec(r->float_utf8);
10917 Safefree(r->substrs);
10919 RX_MATCH_COPY_FREE(rx);
10920 #ifdef PERL_OLD_COPY_ON_WRITE
10921 SvREFCNT_dec(r->saved_copy);
10928 This is a hacky workaround to the structural issue of match results
10929 being stored in the regexp structure which is in turn stored in
10930 PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
10931 could be PL_curpm in multiple contexts, and could require multiple
10932 result sets being associated with the pattern simultaneously, such
10933 as when doing a recursive match with (??{$qr})
10935 The solution is to make a lightweight copy of the regexp structure
10936 when a qr// is returned from the code executed by (??{$qr}) this
10937 lightweight copy doesn't actually own any of its data except for
10938 the starp/end and the actual regexp structure itself.
10944 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
10946 struct regexp *ret;
10947 struct regexp *const r = (struct regexp *)SvANY(rx);
10948 register const I32 npar = r->nparens+1;
10950 PERL_ARGS_ASSERT_REG_TEMP_COPY;
10953 ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
10954 ret = (struct regexp *)SvANY(ret_x);
10956 (void)ReREFCNT_inc(rx);
10957 /* We can take advantage of the existing "copied buffer" mechanism in SVs
10958 by pointing directly at the buffer, but flagging that the allocated
10959 space in the copy is zero. As we've just done a struct copy, it's now
10960 a case of zero-ing that, rather than copying the current length. */
10961 SvPV_set(ret_x, RX_WRAPPED(rx));
10962 SvFLAGS(ret_x) |= SvFLAGS(rx) & (SVf_POK|SVp_POK|SVf_UTF8);
10963 memcpy(&(ret->xpv_cur), &(r->xpv_cur),
10964 sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
10965 SvLEN_set(ret_x, 0);
10966 SvSTASH_set(ret_x, NULL);
10967 SvMAGIC_set(ret_x, NULL);
10968 Newx(ret->offs, npar, regexp_paren_pair);
10969 Copy(r->offs, ret->offs, npar, regexp_paren_pair);
10971 Newx(ret->substrs, 1, struct reg_substr_data);
10972 StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
10974 SvREFCNT_inc_void(ret->anchored_substr);
10975 SvREFCNT_inc_void(ret->anchored_utf8);
10976 SvREFCNT_inc_void(ret->float_substr);
10977 SvREFCNT_inc_void(ret->float_utf8);
10979 /* check_substr and check_utf8, if non-NULL, point to either their
10980 anchored or float namesakes, and don't hold a second reference. */
10982 RX_MATCH_COPIED_off(ret_x);
10983 #ifdef PERL_OLD_COPY_ON_WRITE
10984 ret->saved_copy = NULL;
10986 ret->mother_re = rx;
10992 /* regfree_internal()
10994 Free the private data in a regexp. This is overloadable by
10995 extensions. Perl takes care of the regexp structure in pregfree(),
10996 this covers the *pprivate pointer which technically perl doesn't
10997 know about, however of course we have to handle the
10998 regexp_internal structure when no extension is in use.
11000 Note this is called before freeing anything in the regexp
11005 Perl_regfree_internal(pTHX_ REGEXP * const rx)
11008 struct regexp *const r = (struct regexp *)SvANY(rx);
11009 RXi_GET_DECL(r,ri);
11010 GET_RE_DEBUG_FLAGS_DECL;
11012 PERL_ARGS_ASSERT_REGFREE_INTERNAL;
11018 SV *dsv= sv_newmortal();
11019 RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
11020 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
11021 PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n",
11022 PL_colors[4],PL_colors[5],s);
11025 #ifdef RE_TRACK_PATTERN_OFFSETS
11027 Safefree(ri->u.offsets); /* 20010421 MJD */
11030 int n = ri->data->count;
11031 PAD* new_comppad = NULL;
11036 /* If you add a ->what type here, update the comment in regcomp.h */
11037 switch (ri->data->what[n]) {
11042 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
11045 Safefree(ri->data->data[n]);
11048 new_comppad = MUTABLE_AV(ri->data->data[n]);
11051 if (new_comppad == NULL)
11052 Perl_croak(aTHX_ "panic: pregfree comppad");
11053 PAD_SAVE_LOCAL(old_comppad,
11054 /* Watch out for global destruction's random ordering. */
11055 (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
11058 refcnt = OpREFCNT_dec((OP_4tree*)ri->data->data[n]);
11061 op_free((OP_4tree*)ri->data->data[n]);
11063 PAD_RESTORE_LOCAL(old_comppad);
11064 SvREFCNT_dec(MUTABLE_SV(new_comppad));
11065 new_comppad = NULL;
11070 { /* Aho Corasick add-on structure for a trie node.
11071 Used in stclass optimization only */
11073 reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
11075 refcount = --aho->refcount;
11078 PerlMemShared_free(aho->states);
11079 PerlMemShared_free(aho->fail);
11080 /* do this last!!!! */
11081 PerlMemShared_free(ri->data->data[n]);
11082 PerlMemShared_free(ri->regstclass);
11088 /* trie structure. */
11090 reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
11092 refcount = --trie->refcount;
11095 PerlMemShared_free(trie->charmap);
11096 PerlMemShared_free(trie->states);
11097 PerlMemShared_free(trie->trans);
11099 PerlMemShared_free(trie->bitmap);
11101 PerlMemShared_free(trie->jump);
11102 PerlMemShared_free(trie->wordinfo);
11103 /* do this last!!!! */
11104 PerlMemShared_free(ri->data->data[n]);
11109 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
11112 Safefree(ri->data->what);
11113 Safefree(ri->data);
11119 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
11120 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
11121 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
11124 re_dup - duplicate a regexp.
11126 This routine is expected to clone a given regexp structure. It is only
11127 compiled under USE_ITHREADS.
11129 After all of the core data stored in struct regexp is duplicated
11130 the regexp_engine.dupe method is used to copy any private data
11131 stored in the *pprivate pointer. This allows extensions to handle
11132 any duplication it needs to do.
11134 See pregfree() and regfree_internal() if you change anything here.
11136 #if defined(USE_ITHREADS)
11137 #ifndef PERL_IN_XSUB_RE
11139 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
11143 const struct regexp *r = (const struct regexp *)SvANY(sstr);
11144 struct regexp *ret = (struct regexp *)SvANY(dstr);
11146 PERL_ARGS_ASSERT_RE_DUP_GUTS;
11148 npar = r->nparens+1;
11149 Newx(ret->offs, npar, regexp_paren_pair);
11150 Copy(r->offs, ret->offs, npar, regexp_paren_pair);
11152 /* no need to copy these */
11153 Newx(ret->swap, npar, regexp_paren_pair);
11156 if (ret->substrs) {
11157 /* Do it this way to avoid reading from *r after the StructCopy().
11158 That way, if any of the sv_dup_inc()s dislodge *r from the L1
11159 cache, it doesn't matter. */
11160 const bool anchored = r->check_substr
11161 ? r->check_substr == r->anchored_substr
11162 : r->check_utf8 == r->anchored_utf8;
11163 Newx(ret->substrs, 1, struct reg_substr_data);
11164 StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
11166 ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
11167 ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
11168 ret->float_substr = sv_dup_inc(ret->float_substr, param);
11169 ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
11171 /* check_substr and check_utf8, if non-NULL, point to either their
11172 anchored or float namesakes, and don't hold a second reference. */
11174 if (ret->check_substr) {
11176 assert(r->check_utf8 == r->anchored_utf8);
11177 ret->check_substr = ret->anchored_substr;
11178 ret->check_utf8 = ret->anchored_utf8;
11180 assert(r->check_substr == r->float_substr);
11181 assert(r->check_utf8 == r->float_utf8);
11182 ret->check_substr = ret->float_substr;
11183 ret->check_utf8 = ret->float_utf8;
11185 } else if (ret->check_utf8) {
11187 ret->check_utf8 = ret->anchored_utf8;
11189 ret->check_utf8 = ret->float_utf8;
11194 RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
11197 RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
11199 if (RX_MATCH_COPIED(dstr))
11200 ret->subbeg = SAVEPVN(ret->subbeg, ret->sublen);
11202 ret->subbeg = NULL;
11203 #ifdef PERL_OLD_COPY_ON_WRITE
11204 ret->saved_copy = NULL;
11207 if (ret->mother_re) {
11208 if (SvPVX_const(dstr) == SvPVX_const(ret->mother_re)) {
11209 /* Our storage points directly to our mother regexp, but that's
11210 1: a buffer in a different thread
11211 2: something we no longer hold a reference on
11212 so we need to copy it locally. */
11213 /* Note we need to sue SvCUR() on our mother_re, because it, in
11214 turn, may well be pointing to its own mother_re. */
11215 SvPV_set(dstr, SAVEPVN(SvPVX_const(ret->mother_re),
11216 SvCUR(ret->mother_re)+1));
11217 SvLEN_set(dstr, SvCUR(ret->mother_re)+1);
11219 ret->mother_re = NULL;
11223 #endif /* PERL_IN_XSUB_RE */
11228 This is the internal complement to regdupe() which is used to copy
11229 the structure pointed to by the *pprivate pointer in the regexp.
11230 This is the core version of the extension overridable cloning hook.
11231 The regexp structure being duplicated will be copied by perl prior
11232 to this and will be provided as the regexp *r argument, however
11233 with the /old/ structures pprivate pointer value. Thus this routine
11234 may override any copying normally done by perl.
11236 It returns a pointer to the new regexp_internal structure.
11240 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
11243 struct regexp *const r = (struct regexp *)SvANY(rx);
11244 regexp_internal *reti;
11246 RXi_GET_DECL(r,ri);
11248 PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
11250 npar = r->nparens+1;
11253 Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);
11254 Copy(ri->program, reti->program, len+1, regnode);
11257 reti->regstclass = NULL;
11260 struct reg_data *d;
11261 const int count = ri->data->count;
11264 Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
11265 char, struct reg_data);
11266 Newx(d->what, count, U8);
11269 for (i = 0; i < count; i++) {
11270 d->what[i] = ri->data->what[i];
11271 switch (d->what[i]) {
11272 /* legal options are one of: sSfpontTua
11273 see also regcomp.h and pregfree() */
11274 case 'a': /* actually an AV, but the dup function is identical. */
11277 case 'p': /* actually an AV, but the dup function is identical. */
11278 case 'u': /* actually an HV, but the dup function is identical. */
11279 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
11282 /* This is cheating. */
11283 Newx(d->data[i], 1, struct regnode_charclass_class);
11284 StructCopy(ri->data->data[i], d->data[i],
11285 struct regnode_charclass_class);
11286 reti->regstclass = (regnode*)d->data[i];
11289 /* Compiled op trees are readonly and in shared memory,
11290 and can thus be shared without duplication. */
11292 d->data[i] = (void*)OpREFCNT_inc((OP*)ri->data->data[i]);
11296 /* Trie stclasses are readonly and can thus be shared
11297 * without duplication. We free the stclass in pregfree
11298 * when the corresponding reg_ac_data struct is freed.
11300 reti->regstclass= ri->regstclass;
11304 ((reg_trie_data*)ri->data->data[i])->refcount++;
11308 d->data[i] = ri->data->data[i];
11311 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
11320 reti->name_list_idx = ri->name_list_idx;
11322 #ifdef RE_TRACK_PATTERN_OFFSETS
11323 if (ri->u.offsets) {
11324 Newx(reti->u.offsets, 2*len+1, U32);
11325 Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
11328 SetProgLen(reti,len);
11331 return (void*)reti;
11334 #endif /* USE_ITHREADS */
11336 #ifndef PERL_IN_XSUB_RE
11339 - regnext - dig the "next" pointer out of a node
11342 Perl_regnext(pTHX_ register regnode *p)
11345 register I32 offset;
11350 if (OP(p) > REGNODE_MAX) { /* regnode.type is unsigned */
11351 Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX);
11354 offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
11363 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
11366 STRLEN l1 = strlen(pat1);
11367 STRLEN l2 = strlen(pat2);
11370 const char *message;
11372 PERL_ARGS_ASSERT_RE_CROAK2;
11378 Copy(pat1, buf, l1 , char);
11379 Copy(pat2, buf + l1, l2 , char);
11380 buf[l1 + l2] = '\n';
11381 buf[l1 + l2 + 1] = '\0';
11383 /* ANSI variant takes additional second argument */
11384 va_start(args, pat2);
11388 msv = vmess(buf, &args);
11390 message = SvPV_const(msv,l1);
11393 Copy(message, buf, l1 , char);
11394 buf[l1-1] = '\0'; /* Overwrite \n */
11395 Perl_croak(aTHX_ "%s", buf);
11398 /* XXX Here's a total kludge. But we need to re-enter for swash routines. */
11400 #ifndef PERL_IN_XSUB_RE
11402 Perl_save_re_context(pTHX)
11406 struct re_save_state *state;
11408 SAVEVPTR(PL_curcop);
11409 SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
11411 state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
11412 PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
11413 SSPUSHUV(SAVEt_RE_STATE);
11415 Copy(&PL_reg_state, state, 1, struct re_save_state);
11417 PL_reg_start_tmp = 0;
11418 PL_reg_start_tmpl = 0;
11419 PL_reg_oldsaved = NULL;
11420 PL_reg_oldsavedlen = 0;
11421 PL_reg_maxiter = 0;
11422 PL_reg_leftiter = 0;
11423 PL_reg_poscache = NULL;
11424 PL_reg_poscache_size = 0;
11425 #ifdef PERL_OLD_COPY_ON_WRITE
11429 /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
11431 const REGEXP * const rx = PM_GETRE(PL_curpm);
11434 for (i = 1; i <= RX_NPARENS(rx); i++) {
11435 char digits[TYPE_CHARS(long)];
11436 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
11437 GV *const *const gvp
11438 = (GV**)hv_fetch(PL_defstash, digits, len, 0);
11441 GV * const gv = *gvp;
11442 if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
11452 clear_re(pTHX_ void *r)
11455 ReREFCNT_dec((REGEXP *)r);
11461 S_put_byte(pTHX_ SV *sv, int c)
11463 PERL_ARGS_ASSERT_PUT_BYTE;
11465 /* Our definition of isPRINT() ignores locales, so only bytes that are
11466 not part of UTF-8 are considered printable. I assume that the same
11467 holds for UTF-EBCDIC.
11468 Also, code point 255 is not printable in either (it's E0 in EBCDIC,
11469 which Wikipedia says:
11471 EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all
11472 ones (binary 1111 1111, hexadecimal FF). It is similar, but not
11473 identical, to the ASCII delete (DEL) or rubout control character.
11474 ) So the old condition can be simplified to !isPRINT(c) */
11477 Perl_sv_catpvf(aTHX_ sv, "\\x%02x", c);
11480 Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c);
11484 const char string = c;
11485 if (c == '-' || c == ']' || c == '\\' || c == '^')
11486 sv_catpvs(sv, "\\");
11487 sv_catpvn(sv, &string, 1);
11492 #define CLEAR_OPTSTART \
11493 if (optstart) STMT_START { \
11494 DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
11498 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
11500 STATIC const regnode *
11501 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
11502 const regnode *last, const regnode *plast,
11503 SV* sv, I32 indent, U32 depth)
11506 register U8 op = PSEUDO; /* Arbitrary non-END op. */
11507 register const regnode *next;
11508 const regnode *optstart= NULL;
11510 RXi_GET_DECL(r,ri);
11511 GET_RE_DEBUG_FLAGS_DECL;
11513 PERL_ARGS_ASSERT_DUMPUNTIL;
11515 #ifdef DEBUG_DUMPUNTIL
11516 PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
11517 last ? last-start : 0,plast ? plast-start : 0);
11520 if (plast && plast < last)
11523 while (PL_regkind[op] != END && (!last || node < last)) {
11524 /* While that wasn't END last time... */
11527 if (op == CLOSE || op == WHILEM)
11529 next = regnext((regnode *)node);
11532 if (OP(node) == OPTIMIZED) {
11533 if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
11540 regprop(r, sv, node);
11541 PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
11542 (int)(2*indent + 1), "", SvPVX_const(sv));
11544 if (OP(node) != OPTIMIZED) {
11545 if (next == NULL) /* Next ptr. */
11546 PerlIO_printf(Perl_debug_log, " (0)");
11547 else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
11548 PerlIO_printf(Perl_debug_log, " (FAIL)");
11550 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
11551 (void)PerlIO_putc(Perl_debug_log, '\n');
11555 if (PL_regkind[(U8)op] == BRANCHJ) {
11558 register const regnode *nnode = (OP(next) == LONGJMP
11559 ? regnext((regnode *)next)
11561 if (last && nnode > last)
11563 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
11566 else if (PL_regkind[(U8)op] == BRANCH) {
11568 DUMPUNTIL(NEXTOPER(node), next);
11570 else if ( PL_regkind[(U8)op] == TRIE ) {
11571 const regnode *this_trie = node;
11572 const char op = OP(node);
11573 const U32 n = ARG(node);
11574 const reg_ac_data * const ac = op>=AHOCORASICK ?
11575 (reg_ac_data *)ri->data->data[n] :
11577 const reg_trie_data * const trie =
11578 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
11580 AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
11582 const regnode *nextbranch= NULL;
11585 for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
11586 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
11588 PerlIO_printf(Perl_debug_log, "%*s%s ",
11589 (int)(2*(indent+3)), "",
11590 elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
11591 PL_colors[0], PL_colors[1],
11592 (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
11593 PERL_PV_PRETTY_ELLIPSES |
11594 PERL_PV_PRETTY_LTGT
11599 U16 dist= trie->jump[word_idx+1];
11600 PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
11601 (UV)((dist ? this_trie + dist : next) - start));
11604 nextbranch= this_trie + trie->jump[0];
11605 DUMPUNTIL(this_trie + dist, nextbranch);
11607 if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
11608 nextbranch= regnext((regnode *)nextbranch);
11610 PerlIO_printf(Perl_debug_log, "\n");
11613 if (last && next > last)
11618 else if ( op == CURLY ) { /* "next" might be very big: optimizer */
11619 DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
11620 NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
11622 else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
11624 DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
11626 else if ( op == PLUS || op == STAR) {
11627 DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
11629 else if (PL_regkind[(U8)op] == ANYOF) {
11630 /* arglen 1 + class block */
11631 node += 1 + ((ANYOF_FLAGS(node) & ANYOF_CLASS)
11632 ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
11633 node = NEXTOPER(node);
11635 else if (PL_regkind[(U8)op] == EXACT) {
11636 /* Literal string, where present. */
11637 node += NODE_SZ_STR(node) - 1;
11638 node = NEXTOPER(node);
11641 node = NEXTOPER(node);
11642 node += regarglen[(U8)op];
11644 if (op == CURLYX || op == OPEN)
11648 #ifdef DEBUG_DUMPUNTIL
11649 PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
11654 #endif /* DEBUGGING */
11658 * c-indentation-style: bsd
11659 * c-basic-offset: 4
11660 * indent-tabs-mode: t
11663 * ex: set ts=8 sts=4 sw=4 noet:
https://perl5.git.perl.org / perl5.git / blob