* with the POSIX routines of the same names.
*/
-#ifdef PERL_EXT_RE_BUILD
-#include "re_top.h"
-#endif
-
/*
* pregcomp and pregexec -- regsub and regerror are not used in perl
*
* #ifndef PERL_IN_XSUB_RE
* ...
* #endif
- * blocks, so there is only one defintion for them in the whole
+ * blocks, so there is only one definition for them in the whole
* executable, the one in regcomp.c (or regexec.c). The implication of
* that is any debugging info that comes from them is controlled only by
* -Dr. Further, any static function they call will also be the version
* access data that we don't want to duplicate.
*/
+#ifdef PERL_EXT_RE_BUILD
+#include "re_top.h"
+#endif
+
#include "EXTERN.h"
+#define PERL_IN_REGEX_ENGINE
+#define PERL_IN_REGCOMP_ANY
#define PERL_IN_REGCOMP_C
#include "perl.h"
-#define REG_COMP_C
#ifdef PERL_IN_XSUB_RE
# include "re_comp.h"
EXTERN_C const struct regexp_engine my_reg_engine;
#include "invlist_inline.h"
#include "unicode_constants.h"
-
-#ifndef STATIC
-#define STATIC static
-#endif
-
-/* this is a chain of data about sub patterns we are processing that
- need to be handled separately/specially in study_chunk. Its so
- we can simulate recursion without losing state. */
-struct scan_frame;
-typedef struct scan_frame {
- regnode *last_regnode; /* last node to process in this frame */
- regnode *next_regnode; /* next node to process when last is reached */
- U32 prev_recursed_depth;
- I32 stopparen; /* what stopparen do we use */
- bool in_gosub; /* this or an outer frame is for GOSUB */
-
- struct scan_frame *this_prev_frame; /* this previous frame */
- struct scan_frame *prev_frame; /* previous frame */
- struct scan_frame *next_frame; /* next frame */
-} scan_frame;
-
-/* Certain characters are output as a sequence with the first being a
- * backslash. */
-#define isBACKSLASHED_PUNCT(c) memCHRs("-[]\\^", c)
-
-
-struct RExC_state_t {
- U32 flags; /* RXf_* are we folding, multilining? */
- U32 pm_flags; /* PMf_* stuff from the calling PMOP */
- char *precomp; /* uncompiled string. */
- char *precomp_end; /* pointer to end of uncompiled string. */
- REGEXP *rx_sv; /* The SV that is the regexp. */
- regexp *rx; /* perl core regexp structure */
- regexp_internal *rxi; /* internal data for regexp object
- pprivate field */
- char *start; /* Start of input for compile */
- char *end; /* End of input for compile */
- char *parse; /* Input-scan pointer. */
- char *copy_start; /* start of copy of input within
- constructed parse string */
- char *save_copy_start; /* Provides one level of saving
- and restoring 'copy_start' */
- char *copy_start_in_input; /* Position in input string
- corresponding to copy_start */
- SSize_t whilem_seen; /* number of WHILEM in this expr */
- regnode *emit_start; /* Start of emitted-code area */
- regnode_offset emit; /* Code-emit pointer */
- I32 naughty; /* How bad is this pattern? */
- I32 sawback; /* Did we see \1, ...? */
- SSize_t size; /* Number of regnode equivalents in
- pattern */
- Size_t sets_depth; /* Counts recursion depth of already-
- compiled regex set patterns */
- U32 seen;
-
- I32 parens_buf_size; /* #slots malloced open/close_parens */
- regnode_offset *open_parens; /* offsets to open parens */
- regnode_offset *close_parens; /* offsets to close parens */
- HV *paren_names; /* Paren names */
-
- /* position beyond 'precomp' of the warning message furthest away from
- * 'precomp'. During the parse, no warnings are raised for any problems
- * earlier in the parse than this position. This works if warnings are
- * raised the first time a given spot is parsed, and if only one
- * independent warning is raised for any given spot */
- Size_t latest_warn_offset;
-
- I32 npar; /* Capture buffer count so far in the
- parse, (OPEN) plus one. ("par" 0 is
- the whole pattern)*/
- I32 total_par; /* During initial parse, is either 0,
- or -1; the latter indicating a
- reparse is needed. After that pass,
- it is what 'npar' became after the
- pass. Hence, it being > 0 indicates
- we are in a reparse situation */
- I32 nestroot; /* root parens we are in - used by
- accept */
- I32 seen_zerolen;
- regnode *end_op; /* END node in program */
- I32 utf8; /* whether the pattern is utf8 or not */
- I32 orig_utf8; /* whether the pattern was originally in utf8 */
- /* XXX use this for future optimisation of case
- * where pattern must be upgraded to utf8. */
- I32 uni_semantics; /* If a d charset modifier should use unicode
- rules, even if the pattern is not in
- utf8 */
-
- I32 recurse_count; /* Number of recurse regops we have generated */
- regnode **recurse; /* Recurse regops */
- U8 *study_chunk_recursed; /* bitmap of which subs we have moved
- through */
- U32 study_chunk_recursed_bytes; /* bytes in bitmap */
- I32 in_lookaround;
- I32 contains_locale;
- I32 override_recoding;
- I32 recode_x_to_native;
- I32 in_multi_char_class;
- int code_index; /* next code_blocks[] slot */
- struct reg_code_blocks *code_blocks;/* positions of literal (?{})
- within pattern */
- SSize_t maxlen; /* mininum possible number of chars in string to match */
- scan_frame *frame_head;
- scan_frame *frame_last;
- U32 frame_count;
- AV *warn_text;
- HV *unlexed_names;
- SV *runtime_code_qr; /* qr with the runtime code blocks */
-#ifdef DEBUGGING
- const char *lastparse;
- I32 lastnum;
- U32 study_chunk_recursed_count;
- AV *paren_name_list; /* idx -> name */
- SV *mysv1;
- SV *mysv2;
-
-#define RExC_lastparse (pRExC_state->lastparse)
-#define RExC_lastnum (pRExC_state->lastnum)
-#define RExC_paren_name_list (pRExC_state->paren_name_list)
-#define RExC_study_chunk_recursed_count (pRExC_state->study_chunk_recursed_count)
-#define RExC_mysv (pRExC_state->mysv1)
-#define RExC_mysv1 (pRExC_state->mysv1)
-#define RExC_mysv2 (pRExC_state->mysv2)
-
-#endif
- bool seen_d_op;
- bool strict;
- bool study_started;
- bool in_script_run;
- bool use_BRANCHJ;
- bool sWARN_EXPERIMENTAL__VLB;
- bool sWARN_EXPERIMENTAL__REGEX_SETS;
-};
-
-#define RExC_flags (pRExC_state->flags)
-#define RExC_pm_flags (pRExC_state->pm_flags)
-#define RExC_precomp (pRExC_state->precomp)
-#define RExC_copy_start_in_input (pRExC_state->copy_start_in_input)
-#define RExC_copy_start_in_constructed (pRExC_state->copy_start)
-#define RExC_save_copy_start_in_constructed (pRExC_state->save_copy_start)
-#define RExC_precomp_end (pRExC_state->precomp_end)
-#define RExC_rx_sv (pRExC_state->rx_sv)
-#define RExC_rx (pRExC_state->rx)
-#define RExC_rxi (pRExC_state->rxi)
-#define RExC_start (pRExC_state->start)
-#define RExC_end (pRExC_state->end)
-#define RExC_parse (pRExC_state->parse)
-#define RExC_latest_warn_offset (pRExC_state->latest_warn_offset )
-#define RExC_whilem_seen (pRExC_state->whilem_seen)
-#define RExC_seen_d_op (pRExC_state->seen_d_op) /* Seen something that differs
- under /d from /u ? */
-
-#ifdef RE_TRACK_PATTERN_OFFSETS
-# define RExC_offsets (RExC_rxi->u.offsets) /* I am not like the
- others */
-#endif
-#define RExC_emit (pRExC_state->emit)
-#define RExC_emit_start (pRExC_state->emit_start)
-#define RExC_sawback (pRExC_state->sawback)
-#define RExC_seen (pRExC_state->seen)
-#define RExC_size (pRExC_state->size)
-#define RExC_maxlen (pRExC_state->maxlen)
-#define RExC_npar (pRExC_state->npar)
-#define RExC_total_parens (pRExC_state->total_par)
-#define RExC_parens_buf_size (pRExC_state->parens_buf_size)
-#define RExC_nestroot (pRExC_state->nestroot)
-#define RExC_seen_zerolen (pRExC_state->seen_zerolen)
-#define RExC_utf8 (pRExC_state->utf8)
-#define RExC_uni_semantics (pRExC_state->uni_semantics)
-#define RExC_orig_utf8 (pRExC_state->orig_utf8)
-#define RExC_open_parens (pRExC_state->open_parens)
-#define RExC_close_parens (pRExC_state->close_parens)
-#define RExC_end_op (pRExC_state->end_op)
-#define RExC_paren_names (pRExC_state->paren_names)
-#define RExC_recurse (pRExC_state->recurse)
-#define RExC_recurse_count (pRExC_state->recurse_count)
-#define RExC_sets_depth (pRExC_state->sets_depth)
-#define RExC_study_chunk_recursed (pRExC_state->study_chunk_recursed)
-#define RExC_study_chunk_recursed_bytes \
- (pRExC_state->study_chunk_recursed_bytes)
-#define RExC_in_lookaround (pRExC_state->in_lookaround)
-#define RExC_contains_locale (pRExC_state->contains_locale)
-#define RExC_recode_x_to_native (pRExC_state->recode_x_to_native)
-
-#ifdef EBCDIC
-# define SET_recode_x_to_native(x) \
- STMT_START { RExC_recode_x_to_native = (x); } STMT_END
-#else
-# define SET_recode_x_to_native(x) NOOP
-#endif
-
-#define RExC_in_multi_char_class (pRExC_state->in_multi_char_class)
-#define RExC_frame_head (pRExC_state->frame_head)
-#define RExC_frame_last (pRExC_state->frame_last)
-#define RExC_frame_count (pRExC_state->frame_count)
-#define RExC_strict (pRExC_state->strict)
-#define RExC_study_started (pRExC_state->study_started)
-#define RExC_warn_text (pRExC_state->warn_text)
-#define RExC_in_script_run (pRExC_state->in_script_run)
-#define RExC_use_BRANCHJ (pRExC_state->use_BRANCHJ)
-#define RExC_warned_WARN_EXPERIMENTAL__VLB (pRExC_state->sWARN_EXPERIMENTAL__VLB)
-#define RExC_warned_WARN_EXPERIMENTAL__REGEX_SETS (pRExC_state->sWARN_EXPERIMENTAL__REGEX_SETS)
-#define RExC_unlexed_names (pRExC_state->unlexed_names)
-
-/* Heuristic check on the complexity of the pattern: if TOO_NAUGHTY, we set
- * a flag to disable back-off on the fixed/floating substrings - if it's
- * a high complexity pattern we assume the benefit of avoiding a full match
- * is worth the cost of checking for the substrings even if they rarely help.
- */
-#define RExC_naughty (pRExC_state->naughty)
-#define TOO_NAUGHTY (10)
-#define MARK_NAUGHTY(add) \
- if (RExC_naughty < TOO_NAUGHTY) \
- RExC_naughty += (add)
-#define MARK_NAUGHTY_EXP(exp, add) \
- if (RExC_naughty < TOO_NAUGHTY) \
- RExC_naughty += RExC_naughty / (exp) + (add)
-
-#define isNON_BRACE_QUANTIFIER(c) ((c) == '*' || (c) == '+' || (c) == '?')
-#define isQUANTIFIER(s,e) ( isNON_BRACE_QUANTIFIER(*s) \
- || ((*s) == '{' && regcurly(s, e, NULL)))
-
-/*
- * Flags to be passed up and down.
- */
-#define HASWIDTH 0x01 /* Known to not match null strings, could match
- non-null ones. */
-#define SIMPLE 0x02 /* Exactly one character wide */
- /* (or LNBREAK as a special case) */
-#define POSTPONED 0x08 /* (?1),(?&name), (??{...}) or similar */
-#define TRYAGAIN 0x10 /* Weeded out a declaration. */
-#define RESTART_PARSE 0x20 /* Need to redo the parse */
-#define NEED_UTF8 0x40 /* In conjunction with RESTART_PARSE, need to
- calcuate sizes as UTF-8 */
-
-#define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
-
-/* whether trie related optimizations are enabled */
-#if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
-#define TRIE_STUDY_OPT
-#define FULL_TRIE_STUDY
-#define TRIE_STCLASS
-#endif
-
-
-
-#define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
-#define PBITVAL(paren) (1 << ((paren) & 7))
-#define PAREN_OFFSET(depth) \
- (RExC_study_chunk_recursed + (depth) * RExC_study_chunk_recursed_bytes)
-#define PAREN_TEST(depth, paren) \
- (PBYTE(PAREN_OFFSET(depth), paren) & PBITVAL(paren))
-#define PAREN_SET(depth, paren) \
- (PBYTE(PAREN_OFFSET(depth), paren) |= PBITVAL(paren))
-#define PAREN_UNSET(depth, paren) \
- (PBYTE(PAREN_OFFSET(depth), paren) &= ~PBITVAL(paren))
-
-#define REQUIRE_UTF8(flagp) STMT_START { \
- if (!UTF) { \
- *flagp = RESTART_PARSE|NEED_UTF8; \
- return 0; \
- } \
- } STMT_END
-
-/* /u is to be chosen if we are supposed to use Unicode rules, or if the
- * pattern is in UTF-8. This latter condition is in case the outermost rules
- * are locale. See GH #17278 */
-#define toUSE_UNI_CHARSET_NOT_DEPENDS (RExC_uni_semantics || UTF)
-
-/* Change from /d into /u rules, and restart the parse. RExC_uni_semantics is
- * a flag that indicates we need to override /d with /u as a result of
- * something in the pattern. It should only be used in regards to calling
- * set_regex_charset() or get_regex_charset() */
-#define REQUIRE_UNI_RULES(flagp, restart_retval) \
- STMT_START { \
- if (DEPENDS_SEMANTICS) { \
- set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET); \
- RExC_uni_semantics = 1; \
- if (RExC_seen_d_op && LIKELY(! IN_PARENS_PASS)) { \
- /* No need to restart the parse if we haven't seen \
- * anything that differs between /u and /d, and no need \
- * to restart immediately if we're going to reparse \
- * anyway to count parens */ \
- *flagp |= RESTART_PARSE; \
- return restart_retval; \
- } \
- } \
- } STMT_END
-
-#define REQUIRE_BRANCHJ(flagp, restart_retval) \
- STMT_START { \
- RExC_use_BRANCHJ = 1; \
- *flagp |= RESTART_PARSE; \
- return restart_retval; \
- } STMT_END
-
-/* Until we have completed the parse, we leave RExC_total_parens at 0 or
- * less. After that, it must always be positive, because the whole re is
- * considered to be surrounded by virtual parens. Setting it to negative
- * indicates there is some construct that needs to know the actual number of
- * parens to be properly handled. And that means an extra pass will be
- * required after we've counted them all */
-#define ALL_PARENS_COUNTED (RExC_total_parens > 0)
-#define REQUIRE_PARENS_PASS \
- STMT_START { /* No-op if have completed a pass */ \
- if (! ALL_PARENS_COUNTED) RExC_total_parens = -1; \
- } STMT_END
-#define IN_PARENS_PASS (RExC_total_parens < 0)
-
-
-/* This is used to return failure (zero) early from the calling function if
- * various flags in 'flags' are set. Two flags always cause a return:
- * 'RESTART_PARSE' and 'NEED_UTF8'. 'extra' can be used to specify any
- * additional flags that should cause a return; 0 if none. If the return will
- * be done, '*flagp' is first set to be all of the flags that caused the
- * return. */
-#define RETURN_FAIL_ON_RESTART_OR_FLAGS(flags,flagp,extra) \
- STMT_START { \
- if ((flags) & (RESTART_PARSE|NEED_UTF8|(extra))) { \
- *(flagp) = (flags) & (RESTART_PARSE|NEED_UTF8|(extra)); \
- return 0; \
- } \
- } STMT_END
-
-#define MUST_RESTART(flags) ((flags) & (RESTART_PARSE))
-
-#define RETURN_FAIL_ON_RESTART(flags,flagp) \
- RETURN_FAIL_ON_RESTART_OR_FLAGS( flags, flagp, 0)
-#define RETURN_FAIL_ON_RESTART_FLAGP(flagp) \
- if (MUST_RESTART(*(flagp))) return 0
-
-/* This converts the named class defined in regcomp.h to its equivalent class
- * number defined in handy.h. */
-#define namedclass_to_classnum(class) ((int) ((class) / 2))
-#define classnum_to_namedclass(classnum) ((classnum) * 2)
-
-#define _invlist_union_complement_2nd(a, b, output) \
- _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
-#define _invlist_intersection_complement_2nd(a, b, output) \
- _invlist_intersection_maybe_complement_2nd(a, b, TRUE, output)
-
-/* We add a marker if we are deferring expansion of a property that is both
- * 1) potentiallly user-defined; and
- * 2) could also be an official Unicode property.
- *
- * Without this marker, any deferred expansion can only be for a user-defined
- * one. This marker shouldn't conflict with any that could be in a legal name,
- * and is appended to its name to indicate this. There is a string and
- * character form */
-#define DEFERRED_COULD_BE_OFFICIAL_MARKERs "~"
-#define DEFERRED_COULD_BE_OFFICIAL_MARKERc '~'
-
-/* What is infinity for optimization purposes */
-#define OPTIMIZE_INFTY SSize_t_MAX
-
-/* About scan_data_t.
-
- During optimisation we recurse through the regexp program performing
- various inplace (keyhole style) optimisations. In addition study_chunk
- and scan_commit populate this data structure with information about
- what strings MUST appear in the pattern. We look for the longest
- string that must appear at a fixed location, and we look for the
- longest string that may appear at a floating location. So for instance
- in the pattern:
-
- /FOO[xX]A.*B[xX]BAR/
-
- Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
- strings (because they follow a .* construct). study_chunk will identify
- both FOO and BAR as being the longest fixed and floating strings respectively.
-
- The strings can be composites, for instance
-
- /(f)(o)(o)/
-
- will result in a composite fixed substring 'foo'.
-
- For each string some basic information is maintained:
-
- - min_offset
- This is the position the string must appear at, or not before.
- It also implicitly (when combined with minlenp) tells us how many
- characters must match before the string we are searching for.
- Likewise when combined with minlenp and the length of the string it
- tells us how many characters must appear after the string we have
- found.
-
- - max_offset
- Only used for floating strings. This is the rightmost point that
- the string can appear at. If set to OPTIMIZE_INFTY it indicates that the
- string can occur infinitely far to the right.
- For fixed strings, it is equal to min_offset.
-
- - minlenp
- A pointer to the minimum number of characters of the pattern that the
- string was found inside. This is important as in the case of positive
- lookahead or positive lookbehind we can have multiple patterns
- involved. Consider
-
- /(?=FOO).*F/
-
- The minimum length of the pattern overall is 3, the minimum length
- of the lookahead part is 3, but the minimum length of the part that
- will actually match is 1. So 'FOO's minimum length is 3, but the
- minimum length for the F is 1. This is important as the minimum length
- is used to determine offsets in front of and behind the string being
- looked for. Since strings can be composites this is the length of the
- pattern at the time it was committed with a scan_commit. Note that
- the length is calculated by study_chunk, so that the minimum lengths
- are not known until the full pattern has been compiled, thus the
- pointer to the value.
-
- - lookbehind
-
- In the case of lookbehind the string being searched for can be
- offset past the start point of the final matching string.
- If this value was just blithely removed from the min_offset it would
- invalidate some of the calculations for how many chars must match
- before or after (as they are derived from min_offset and minlen and
- the length of the string being searched for).
- When the final pattern is compiled and the data is moved from the
- scan_data_t structure into the regexp structure the information
- about lookbehind is factored in, with the information that would
- have been lost precalculated in the end_shift field for the
- associated string.
-
- The fields pos_min and pos_delta are used to store the minimum offset
- and the delta to the maximum offset at the current point in the pattern.
-
-*/
-
-struct scan_data_substrs {
- SV *str; /* longest substring found in pattern */
- SSize_t min_offset; /* earliest point in string it can appear */
- SSize_t max_offset; /* latest point in string it can appear */
- SSize_t *minlenp; /* pointer to the minlen relevant to the string */
- SSize_t lookbehind; /* is the pos of the string modified by LB */
- I32 flags; /* per substring SF_* and SCF_* flags */
-};
-
-typedef struct scan_data_t {
- /*I32 len_min; unused */
- /*I32 len_delta; unused */
- SSize_t pos_min;
- SSize_t pos_delta;
- SV *last_found;
- SSize_t last_end; /* min value, <0 unless valid. */
- SSize_t last_start_min;
- SSize_t last_start_max;
- U8 cur_is_floating; /* whether the last_* values should be set as
- * the next fixed (0) or floating (1)
- * substring */
-
- /* [0] is longest fixed substring so far, [1] is longest float so far */
- struct scan_data_substrs substrs[2];
-
- I32 flags; /* common SF_* and SCF_* flags */
- I32 whilem_c;
- SSize_t *last_closep;
- regnode_ssc *start_class;
-} scan_data_t;
-
-/*
- * Forward declarations for pregcomp()'s friends.
- */
-
-static const scan_data_t zero_scan_data = {
- 0, 0, NULL, 0, 0, 0, 0,
- {
- { NULL, 0, 0, 0, 0, 0 },
- { NULL, 0, 0, 0, 0, 0 },
- },
- 0, 0, NULL, NULL
-};
-
-/* study flags */
-
-#define SF_BEFORE_SEOL 0x0001
-#define SF_BEFORE_MEOL 0x0002
-#define SF_BEFORE_EOL (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
-
-#define SF_IS_INF 0x0040
-#define SF_HAS_PAR 0x0080
-#define SF_IN_PAR 0x0100
-#define SF_HAS_EVAL 0x0200
-
-
-/* SCF_DO_SUBSTR is the flag that tells the regexp analyzer to track the
- * longest substring in the pattern. When it is not set the optimiser keeps
- * track of position, but does not keep track of the actual strings seen,
- *
- * So for instance /foo/ will be parsed with SCF_DO_SUBSTR being true, but
- * /foo/i will not.
- *
- * Similarly, /foo.*(blah|erm|huh).*fnorble/ will have "foo" and "fnorble"
- * parsed with SCF_DO_SUBSTR on, but while processing the (...) it will be
- * turned off because of the alternation (BRANCH). */
-#define SCF_DO_SUBSTR 0x0400
-
-#define SCF_DO_STCLASS_AND 0x0800
-#define SCF_DO_STCLASS_OR 0x1000
-#define SCF_DO_STCLASS (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
-#define SCF_WHILEM_VISITED_POS 0x2000
-
-#define SCF_TRIE_RESTUDY 0x4000 /* Do restudy? */
-#define SCF_SEEN_ACCEPT 0x8000
-#define SCF_TRIE_DOING_RESTUDY 0x10000
-#define SCF_IN_DEFINE 0x20000
-
-
-
-
-#define UTF cBOOL(RExC_utf8)
-
-/* The enums for all these are ordered so things work out correctly */
-#define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
-#define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags) \
- == REGEX_DEPENDS_CHARSET)
-#define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
-#define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags) \
- >= REGEX_UNICODE_CHARSET)
-#define ASCII_RESTRICTED (get_regex_charset(RExC_flags) \
- == REGEX_ASCII_RESTRICTED_CHARSET)
-#define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags) \
- >= REGEX_ASCII_RESTRICTED_CHARSET)
-#define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags) \
- == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
-
-#define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
-
-/* For programs that want to be strictly Unicode compatible by dying if any
- * attempt is made to match a non-Unicode code point against a Unicode
- * property. */
-#define ALWAYS_WARN_SUPER ckDEAD(packWARN(WARN_NON_UNICODE))
-
-#define OOB_NAMEDCLASS -1
-
-/* There is no code point that is out-of-bounds, so this is problematic. But
- * its only current use is to initialize a variable that is always set before
- * looked at. */
-#define OOB_UNICODE 0xDEADBEEF
-
-#define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
-
-
-/* length of regex to show in messages that don't mark a position within */
-#define RegexLengthToShowInErrorMessages 127
-
-/*
- * If MARKER[12] are adjusted, be sure to adjust the constants at the top
- * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
- * op/pragma/warn/regcomp.
- */
-#define MARKER1 "<-- HERE" /* marker as it appears in the description */
-#define MARKER2 " <-- HERE " /* marker as it appears within the regex */
-
-#define REPORT_LOCATION " in regex; marked by " MARKER1 \
- " in m/%" UTF8f MARKER2 "%" UTF8f "/"
-
-/* The code in this file in places uses one level of recursion with parsing
- * rebased to an alternate string constructed by us in memory. This can take
- * the form of something that is completely different from the input, or
- * something that uses the input as part of the alternate. In the first case,
- * there should be no possibility of an error, as we are in complete control of
- * the alternate string. But in the second case we don't completely control
- * the input portion, so there may be errors in that. Here's an example:
- * /[abc\x{DF}def]/ui
- * is handled specially because \x{df} folds to a sequence of more than one
- * character: 'ss'. What is done is to create and parse an alternate string,
- * which looks like this:
- * /(?:\x{DF}|[abc\x{DF}def])/ui
- * where it uses the input unchanged in the middle of something it constructs,
- * which is a branch for the DF outside the character class, and clustering
- * parens around the whole thing. (It knows enough to skip the DF inside the
- * class while in this substitute parse.) 'abc' and 'def' may have errors that
- * need to be reported. The general situation looks like this:
- *
- * |<------- identical ------>|
- * sI tI xI eI
- * Input: ---------------------------------------------------------------
- * Constructed: ---------------------------------------------------
- * sC tC xC eC EC
- * |<------- identical ------>|
- *
- * sI..eI is the portion of the input pattern we are concerned with here.
- * sC..EC is the constructed substitute parse string.
- * sC..tC is constructed by us
- * tC..eC is an exact duplicate of the portion of the input pattern tI..eI.
- * In the diagram, these are vertically aligned.
- * eC..EC is also constructed by us.
- * xC is the position in the substitute parse string where we found a
- * problem.
- * xI is the position in the original pattern corresponding to xC.
- *
- * We want to display a message showing the real input string. Thus we need to
- * translate from xC to xI. We know that xC >= tC, since the portion of the
- * string sC..tC has been constructed by us, and so shouldn't have errors. We
- * get:
- * xI = tI + (xC - tC)
- *
- * When the substitute parse is constructed, the code needs to set:
- * RExC_start (sC)
- * RExC_end (eC)
- * RExC_copy_start_in_input (tI)
- * RExC_copy_start_in_constructed (tC)
- * and restore them when done.
- *
- * During normal processing of the input pattern, both
- * 'RExC_copy_start_in_input' and 'RExC_copy_start_in_constructed' are set to
- * sI, so that xC equals xI.
- */
-
-#define sI RExC_precomp
-#define eI RExC_precomp_end
-#define sC RExC_start
-#define eC RExC_end
-#define tI RExC_copy_start_in_input
-#define tC RExC_copy_start_in_constructed
-#define xI(xC) (tI + (xC - tC))
-#define xI_offset(xC) (xI(xC) - sI)
-
-#define REPORT_LOCATION_ARGS(xC) \
- UTF8fARG(UTF, \
- (xI(xC) > eI) /* Don't run off end */ \
- ? eI - sI /* Length before the <--HERE */ \
- : ((xI_offset(xC) >= 0) \
- ? xI_offset(xC) \
- : (Perl_croak(aTHX_ "panic: %s: %d: negative offset: %" \
- IVdf " trying to output message for " \
- " pattern %.*s", \
- __FILE__, __LINE__, (IV) xI_offset(xC), \
- ((int) (eC - sC)), sC), 0)), \
- sI), /* The input pattern printed up to the <--HERE */ \
- UTF8fARG(UTF, \
- (xI(xC) > eI) ? 0 : eI - xI(xC), /* Length after <--HERE */ \
- (xI(xC) > eI) ? eI : xI(xC)) /* pattern after <--HERE */
-
-/* Used to point after bad bytes for an error message, but avoid skipping
- * past a nul byte. */
-#define SKIP_IF_CHAR(s, e) (!*(s) ? 0 : UTF ? UTF8_SAFE_SKIP(s, e) : 1)
-
-/* Set up to clean up after our imminent demise */
-#define PREPARE_TO_DIE \
- STMT_START { \
- if (RExC_rx_sv) \
- SAVEFREESV(RExC_rx_sv); \
- if (RExC_open_parens) \
- SAVEFREEPV(RExC_open_parens); \
- if (RExC_close_parens) \
- SAVEFREEPV(RExC_close_parens); \
- } STMT_END
-
-/*
- * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
- * arg. Show regex, up to a maximum length. If it's too long, chop and add
- * "...".
- */
-#define _FAIL(code) STMT_START { \
- const char *ellipses = ""; \
- IV len = RExC_precomp_end - RExC_precomp; \
- \
- PREPARE_TO_DIE; \
- if (len > RegexLengthToShowInErrorMessages) { \
- /* chop 10 shorter than the max, to ensure meaning of "..." */ \
- len = RegexLengthToShowInErrorMessages - 10; \
- ellipses = "..."; \
- } \
- code; \
-} STMT_END
-
-#define FAIL(msg) _FAIL( \
- Perl_croak(aTHX_ "%s in regex m/%" UTF8f "%s/", \
- msg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
-
-#define FAIL2(msg,arg) _FAIL( \
- Perl_croak(aTHX_ msg " in regex m/%" UTF8f "%s/", \
- arg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
-
-#define FAIL3(msg,arg1,arg2) _FAIL( \
- Perl_croak(aTHX_ msg " in regex m/%" UTF8f "%s/", \
- arg1, arg2, UTF8fARG(UTF, len, RExC_precomp), ellipses))
-
-/*
- * Simple_vFAIL -- like FAIL, but marks the current location in the scan
- */
-#define Simple_vFAIL(m) STMT_START { \
- Perl_croak(aTHX_ "%s" REPORT_LOCATION, \
- m, REPORT_LOCATION_ARGS(RExC_parse)); \
-} STMT_END
-
-/*
- * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
- */
-#define vFAIL(m) STMT_START { \
- PREPARE_TO_DIE; \
- Simple_vFAIL(m); \
-} STMT_END
-
-/*
- * Like Simple_vFAIL(), but accepts two arguments.
- */
-#define Simple_vFAIL2(m,a1) STMT_START { \
- S_re_croak(aTHX_ UTF, m REPORT_LOCATION, a1, \
- REPORT_LOCATION_ARGS(RExC_parse)); \
-} STMT_END
-
-/*
- * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
- */
-#define vFAIL2(m,a1) STMT_START { \
- PREPARE_TO_DIE; \
- Simple_vFAIL2(m, a1); \
-} STMT_END
-
-
-/*
- * Like Simple_vFAIL(), but accepts three arguments.
- */
-#define Simple_vFAIL3(m, a1, a2) STMT_START { \
- S_re_croak(aTHX_ UTF, m REPORT_LOCATION, a1, a2, \
- REPORT_LOCATION_ARGS(RExC_parse)); \
-} STMT_END
-
-/*
- * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
- */
-#define vFAIL3(m,a1,a2) STMT_START { \
- PREPARE_TO_DIE; \
- Simple_vFAIL3(m, a1, a2); \
-} STMT_END
-
-/*
- * Like Simple_vFAIL(), but accepts four arguments.
- */
-#define Simple_vFAIL4(m, a1, a2, a3) STMT_START { \
- S_re_croak(aTHX_ UTF, m REPORT_LOCATION, a1, a2, a3, \
- REPORT_LOCATION_ARGS(RExC_parse)); \
-} STMT_END
-
-#define vFAIL4(m,a1,a2,a3) STMT_START { \
- PREPARE_TO_DIE; \
- Simple_vFAIL4(m, a1, a2, a3); \
-} STMT_END
-
-/* A specialized version of vFAIL2 that works with UTF8f */
-#define vFAIL2utf8f(m, a1) STMT_START { \
- PREPARE_TO_DIE; \
- S_re_croak(aTHX_ UTF, m REPORT_LOCATION, a1, \
- REPORT_LOCATION_ARGS(RExC_parse)); \
-} STMT_END
-
-#define vFAIL3utf8f(m, a1, a2) STMT_START { \
- PREPARE_TO_DIE; \
- S_re_croak(aTHX_ UTF, m REPORT_LOCATION, a1, a2, \
- REPORT_LOCATION_ARGS(RExC_parse)); \
-} STMT_END
-
-/* Setting this to NULL is a signal to not output warnings */
-#define TURN_OFF_WARNINGS_IN_SUBSTITUTE_PARSE \
- STMT_START { \
- RExC_save_copy_start_in_constructed = RExC_copy_start_in_constructed;\
- RExC_copy_start_in_constructed = NULL; \
- } STMT_END
-#define RESTORE_WARNINGS \
- RExC_copy_start_in_constructed = RExC_save_copy_start_in_constructed
-
-/* Since a warning can be generated multiple times as the input is reparsed, we
- * output it the first time we come to that point in the parse, but suppress it
- * otherwise. 'RExC_copy_start_in_constructed' being NULL is a flag to not
- * generate any warnings */
-#define TO_OUTPUT_WARNINGS(loc) \
- ( RExC_copy_start_in_constructed \
- && ((xI(loc)) - RExC_precomp) > (Ptrdiff_t) RExC_latest_warn_offset)
-
-/* After we've emitted a warning, we save the position in the input so we don't
- * output it again */
-#define UPDATE_WARNINGS_LOC(loc) \
- STMT_START { \
- if (TO_OUTPUT_WARNINGS(loc)) { \
- RExC_latest_warn_offset = MAX(sI, MIN(eI, xI(loc))) \
- - RExC_precomp; \
- } \
- } STMT_END
-
-/* 'warns' is the output of the packWARNx macro used in 'code' */
-#define _WARN_HELPER(loc, warns, code) \
- STMT_START { \
- if (! RExC_copy_start_in_constructed) { \
- Perl_croak( aTHX_ "panic! %s: %d: Tried to warn when none" \
- " expected at '%s'", \
- __FILE__, __LINE__, loc); \
- } \
- if (TO_OUTPUT_WARNINGS(loc)) { \
- if (ckDEAD(warns)) \
- PREPARE_TO_DIE; \
- code; \
- UPDATE_WARNINGS_LOC(loc); \
- } \
- } STMT_END
-
-/* m is not necessarily a "literal string", in this macro */
-#define warn_non_literal_string(loc, packed_warn, m) \
- _WARN_HELPER(loc, packed_warn, \
- Perl_warner(aTHX_ packed_warn, \
- "%s" REPORT_LOCATION, \
- m, REPORT_LOCATION_ARGS(loc)))
-#define reg_warn_non_literal_string(loc, m) \
- warn_non_literal_string(loc, packWARN(WARN_REGEXP), m)
-
-#define ckWARN2_non_literal_string(loc, packwarn, m, a1) \
- STMT_START { \
- char * format; \
- Size_t format_size = strlen(m) + strlen(REPORT_LOCATION)+ 1;\
- Newx(format, format_size, char); \
- my_strlcpy(format, m, format_size); \
- my_strlcat(format, REPORT_LOCATION, format_size); \
- SAVEFREEPV(format); \
- _WARN_HELPER(loc, packwarn, \
- Perl_ck_warner(aTHX_ packwarn, \
- format, \
- a1, REPORT_LOCATION_ARGS(loc))); \
- } STMT_END
-
-#define ckWARNreg(loc,m) \
- _WARN_HELPER(loc, packWARN(WARN_REGEXP), \
- Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), \
- m REPORT_LOCATION, \
- REPORT_LOCATION_ARGS(loc)))
-
-#define vWARN(loc, m) \
- _WARN_HELPER(loc, packWARN(WARN_REGEXP), \
- Perl_warner(aTHX_ packWARN(WARN_REGEXP), \
- m REPORT_LOCATION, \
- REPORT_LOCATION_ARGS(loc))) \
-
-#define vWARN_dep(loc, m) \
- _WARN_HELPER(loc, packWARN(WARN_DEPRECATED), \
- Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), \
- m REPORT_LOCATION, \
- REPORT_LOCATION_ARGS(loc)))
-
-#define ckWARNdep(loc,m) \
- _WARN_HELPER(loc, packWARN(WARN_DEPRECATED), \
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), \
- m REPORT_LOCATION, \
- REPORT_LOCATION_ARGS(loc)))
-
-#define ckWARNregdep(loc,m) \
- _WARN_HELPER(loc, packWARN2(WARN_DEPRECATED, WARN_REGEXP), \
- Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, \
- WARN_REGEXP), \
- m REPORT_LOCATION, \
- REPORT_LOCATION_ARGS(loc)))
-
-#define ckWARN2reg_d(loc,m, a1) \
- _WARN_HELPER(loc, packWARN(WARN_REGEXP), \
- Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP), \
- m REPORT_LOCATION, \
- a1, REPORT_LOCATION_ARGS(loc)))
-
-#define ckWARN2reg(loc, m, a1) \
- _WARN_HELPER(loc, packWARN(WARN_REGEXP), \
- Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), \
- m REPORT_LOCATION, \
- a1, REPORT_LOCATION_ARGS(loc)))
-
-#define vWARN3(loc, m, a1, a2) \
- _WARN_HELPER(loc, packWARN(WARN_REGEXP), \
- Perl_warner(aTHX_ packWARN(WARN_REGEXP), \
- m REPORT_LOCATION, \
- a1, a2, REPORT_LOCATION_ARGS(loc)))
-
-#define ckWARN3reg(loc, m, a1, a2) \
- _WARN_HELPER(loc, packWARN(WARN_REGEXP), \
- Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), \
- m REPORT_LOCATION, \
- a1, a2, \
- REPORT_LOCATION_ARGS(loc)))
-
-#define vWARN4(loc, m, a1, a2, a3) \
- _WARN_HELPER(loc, packWARN(WARN_REGEXP), \
- Perl_warner(aTHX_ packWARN(WARN_REGEXP), \
- m REPORT_LOCATION, \
- a1, a2, a3, \
- REPORT_LOCATION_ARGS(loc)))
-
-#define ckWARN4reg(loc, m, a1, a2, a3) \
- _WARN_HELPER(loc, packWARN(WARN_REGEXP), \
- Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), \
- m REPORT_LOCATION, \
- a1, a2, a3, \
- REPORT_LOCATION_ARGS(loc)))
-
-#define vWARN5(loc, m, a1, a2, a3, a4) \
- _WARN_HELPER(loc, packWARN(WARN_REGEXP), \
- Perl_warner(aTHX_ packWARN(WARN_REGEXP), \
- m REPORT_LOCATION, \
- a1, a2, a3, a4, \
- REPORT_LOCATION_ARGS(loc)))
-
-#define ckWARNexperimental(loc, class, m) \
- STMT_START { \
- if (! RExC_warned_ ## class) { /* warn once per compilation */ \
- RExC_warned_ ## class = 1; \
- _WARN_HELPER(loc, packWARN(class), \
- Perl_ck_warner_d(aTHX_ packWARN(class), \
- m REPORT_LOCATION, \
- REPORT_LOCATION_ARGS(loc)));\
- } \
- } STMT_END
-
-/* Convert between a pointer to a node and its offset from the beginning of the
- * program */
-#define REGNODE_p(offset) (RExC_emit_start + (offset))
-#define REGNODE_OFFSET(node) ((node) - RExC_emit_start)
-
-/* Macros for recording node offsets. 20001227 mjd@plover.com
- * Nodes are numbered 1, 2, 3, 4. Node #n's position is recorded in
- * element 2*n-1 of the array. Element #2n holds the byte length node #n.
- * Element 0 holds the number n.
- * Position is 1 indexed.
- */
-#ifndef RE_TRACK_PATTERN_OFFSETS
-#define Set_Node_Offset_To_R(offset,byte)
-#define Set_Node_Offset(node,byte)
-#define Set_Cur_Node_Offset
-#define Set_Node_Length_To_R(node,len)
-#define Set_Node_Length(node,len)
-#define Set_Node_Cur_Length(node,start)
-#define Node_Offset(n)
-#define Node_Length(n)
-#define Set_Node_Offset_Length(node,offset,len)
-#define ProgLen(ri) ri->u.proglen
-#define SetProgLen(ri,x) ri->u.proglen = x
-#define Track_Code(code)
-#else
-#define ProgLen(ri) ri->u.offsets[0]
-#define SetProgLen(ri,x) ri->u.offsets[0] = x
-#define Set_Node_Offset_To_R(offset,byte) STMT_START { \
- MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n", \
- __LINE__, (int)(offset), (int)(byte))); \
- if((offset) < 0) { \
- Perl_croak(aTHX_ "value of node is %d in Offset macro", \
- (int)(offset)); \
- } else { \
- RExC_offsets[2*(offset)-1] = (byte); \
- } \
-} STMT_END
-
-#define Set_Node_Offset(node,byte) \
- Set_Node_Offset_To_R(REGNODE_OFFSET(node), (byte)-RExC_start)
-#define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
-
-#define Set_Node_Length_To_R(node,len) STMT_START { \
- MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n", \
- __LINE__, (int)(node), (int)(len))); \
- if((node) < 0) { \
- Perl_croak(aTHX_ "value of node is %d in Length macro", \
- (int)(node)); \
- } else { \
- RExC_offsets[2*(node)] = (len); \
- } \
-} STMT_END
-
-#define Set_Node_Length(node,len) \
- Set_Node_Length_To_R(REGNODE_OFFSET(node), len)
-#define Set_Node_Cur_Length(node, start) \
- Set_Node_Length(node, RExC_parse - start)
-
-/* Get offsets and lengths */
-#define Node_Offset(n) (RExC_offsets[2*(REGNODE_OFFSET(n))-1])
-#define Node_Length(n) (RExC_offsets[2*(REGNODE_OFFSET(n))])
-
-#define Set_Node_Offset_Length(node,offset,len) STMT_START { \
- Set_Node_Offset_To_R(REGNODE_OFFSET(node), (offset)); \
- Set_Node_Length_To_R(REGNODE_OFFSET(node), (len)); \
-} STMT_END
-
-#define Track_Code(code) STMT_START { code } STMT_END
-#endif
-
-#if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
-#define EXPERIMENTAL_INPLACESCAN
-#endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
-
-#ifdef DEBUGGING
-int
-Perl_re_printf(pTHX_ const char *fmt, ...)
-{
- va_list ap;
- int result;
- PerlIO *f= Perl_debug_log;
- PERL_ARGS_ASSERT_RE_PRINTF;
- va_start(ap, fmt);
- result = PerlIO_vprintf(f, fmt, ap);
- va_end(ap);
- return result;
-}
-
-int
-Perl_re_indentf(pTHX_ const char *fmt, U32 depth, ...)
-{
- va_list ap;
- int result;
- PerlIO *f= Perl_debug_log;
- PERL_ARGS_ASSERT_RE_INDENTF;
- va_start(ap, depth);
- PerlIO_printf(f, "%*s", ( (int)depth % 20 ) * 2, "");
- result = PerlIO_vprintf(f, fmt, ap);
- va_end(ap);
- return result;
-}
-#endif /* DEBUGGING */
-
-#define DEBUG_RExC_seen() \
- DEBUG_OPTIMISE_MORE_r({ \
- Perl_re_printf( aTHX_ "RExC_seen: "); \
- \
- if (RExC_seen & REG_ZERO_LEN_SEEN) \
- Perl_re_printf( aTHX_ "REG_ZERO_LEN_SEEN "); \
- \
- if (RExC_seen & REG_LOOKBEHIND_SEEN) \
- Perl_re_printf( aTHX_ "REG_LOOKBEHIND_SEEN "); \
- \
- if (RExC_seen & REG_GPOS_SEEN) \
- Perl_re_printf( aTHX_ "REG_GPOS_SEEN "); \
- \
- if (RExC_seen & REG_RECURSE_SEEN) \
- Perl_re_printf( aTHX_ "REG_RECURSE_SEEN "); \
- \
- if (RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN) \
- Perl_re_printf( aTHX_ "REG_TOP_LEVEL_BRANCHES_SEEN "); \
- \
- if (RExC_seen & REG_VERBARG_SEEN) \
- Perl_re_printf( aTHX_ "REG_VERBARG_SEEN "); \
- \
- if (RExC_seen & REG_CUTGROUP_SEEN) \
- Perl_re_printf( aTHX_ "REG_CUTGROUP_SEEN "); \
- \
- if (RExC_seen & REG_RUN_ON_COMMENT_SEEN) \
- Perl_re_printf( aTHX_ "REG_RUN_ON_COMMENT_SEEN "); \
- \
- if (RExC_seen & REG_UNFOLDED_MULTI_SEEN) \
- Perl_re_printf( aTHX_ "REG_UNFOLDED_MULTI_SEEN "); \
- \
- if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) \
- Perl_re_printf( aTHX_ "REG_UNBOUNDED_QUANTIFIER_SEEN "); \
- \
- Perl_re_printf( aTHX_ "\n"); \
- });
-
-#define DEBUG_SHOW_STUDY_FLAG(flags,flag) \
- if ((flags) & flag) Perl_re_printf( aTHX_ "%s ", #flag)
-
-
-#ifdef DEBUGGING
-static void
-S_debug_show_study_flags(pTHX_ U32 flags, const char *open_str,
- const char *close_str)
-{
- if (!flags)
- return;
-
- Perl_re_printf( aTHX_ "%s", open_str);
- DEBUG_SHOW_STUDY_FLAG(flags, SF_BEFORE_SEOL);
- DEBUG_SHOW_STUDY_FLAG(flags, SF_BEFORE_MEOL);
- DEBUG_SHOW_STUDY_FLAG(flags, SF_IS_INF);
- DEBUG_SHOW_STUDY_FLAG(flags, SF_HAS_PAR);
- DEBUG_SHOW_STUDY_FLAG(flags, SF_IN_PAR);
- DEBUG_SHOW_STUDY_FLAG(flags, SF_HAS_EVAL);
- DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_SUBSTR);
- DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS_AND);
- DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS_OR);
- DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS);
- DEBUG_SHOW_STUDY_FLAG(flags, SCF_WHILEM_VISITED_POS);
- DEBUG_SHOW_STUDY_FLAG(flags, SCF_TRIE_RESTUDY);
- DEBUG_SHOW_STUDY_FLAG(flags, SCF_SEEN_ACCEPT);
- DEBUG_SHOW_STUDY_FLAG(flags, SCF_TRIE_DOING_RESTUDY);
- DEBUG_SHOW_STUDY_FLAG(flags, SCF_IN_DEFINE);
- Perl_re_printf( aTHX_ "%s", close_str);
-}
-
-
-static void
-S_debug_studydata(pTHX_ const char *where, scan_data_t *data,
- U32 depth, int is_inf)
-{
- DECLARE_AND_GET_RE_DEBUG_FLAGS;
-
- DEBUG_OPTIMISE_MORE_r({
- if (!data)
- return;
- Perl_re_indentf(aTHX_ "%s: Pos:%" IVdf "/%" IVdf " Flags: 0x%" UVXf,
- depth,
- where,
- (IV)data->pos_min,
- (IV)data->pos_delta,
- (UV)data->flags
- );
-
- S_debug_show_study_flags(aTHX_ data->flags," [","]");
-
- Perl_re_printf( aTHX_
- " Whilem_c: %" IVdf " Lcp: %" IVdf " %s",
- (IV)data->whilem_c,
- (IV)(data->last_closep ? *((data)->last_closep) : -1),
- is_inf ? "INF " : ""
- );
-
- if (data->last_found) {
- int i;
- Perl_re_printf(aTHX_
- "Last:'%s' %" IVdf ":%" IVdf "/%" IVdf,
- SvPVX_const(data->last_found),
- (IV)data->last_end,
- (IV)data->last_start_min,
- (IV)data->last_start_max
- );
-
- for (i = 0; i < 2; i++) {
- Perl_re_printf(aTHX_
- " %s%s: '%s' @ %" IVdf "/%" IVdf,
- data->cur_is_floating == i ? "*" : "",
- i ? "Float" : "Fixed",
- SvPVX_const(data->substrs[i].str),
- (IV)data->substrs[i].min_offset,
- (IV)data->substrs[i].max_offset
- );
- S_debug_show_study_flags(aTHX_ data->substrs[i].flags," [","]");
- }
- }
-
- Perl_re_printf( aTHX_ "\n");
- });
-}
-
-
-static void
-S_debug_peep(pTHX_ const char *str, const RExC_state_t *pRExC_state,
- regnode *scan, U32 depth, U32 flags)
-{
- DECLARE_AND_GET_RE_DEBUG_FLAGS;
-
- DEBUG_OPTIMISE_r({
- regnode *Next;
-
- if (!scan)
- return;
- Next = regnext(scan);
- regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
- Perl_re_indentf( aTHX_ "%s>%3d: %s (%d)",
- depth,
- str,
- REG_NODE_NUM(scan), SvPV_nolen_const(RExC_mysv),
- Next ? (REG_NODE_NUM(Next)) : 0 );
- S_debug_show_study_flags(aTHX_ flags," [ ","]");
- Perl_re_printf( aTHX_ "\n");
- });
-}
-
-
-# define DEBUG_STUDYDATA(where, data, depth, is_inf) \
- S_debug_studydata(aTHX_ where, data, depth, is_inf)
-
-# define DEBUG_PEEP(str, scan, depth, flags) \
- S_debug_peep(aTHX_ str, pRExC_state, scan, depth, flags)
-
-#else
-# define DEBUG_STUDYDATA(where, data, depth, is_inf) NOOP
-# define DEBUG_PEEP(str, scan, depth, flags) NOOP
-#endif
-
+#include "regcomp_internal.h"
/* =========================================================
* BEGIN edit_distance stuff.
PERL_ARGS_ASSERT_EDIT_DISTANCE;
- /* intialize matrix start values */
+ /* initialize matrix start values */
Newx(scores, ( (x + 2) * (y + 2)), UV);
scores[0] = score_ceil;
scores[1 * (y + 2) + 0] = score_ceil;
/* END of edit_distance() stuff
* ========================================================= */
-/* Mark that we cannot extend a found fixed substring at this point.
- Update the longest found anchored substring or the longest found
- floating substrings if needed. */
-
-STATIC void
-S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data,
- SSize_t *minlenp, int is_inf)
+#ifdef PERL_RE_BUILD_AUX
+/* add a data member to the struct reg_data attached to this regex, it should
+ * always return a non-zero return. the 's' argument is the type of the items
+ * being added and the n is the number of items. The length of 's' should match
+ * the number of items. */
+U32
+Perl_reg_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
{
- const STRLEN l = CHR_SVLEN(data->last_found);
- SV * const longest_sv = data->substrs[data->cur_is_floating].str;
- const STRLEN old_l = CHR_SVLEN(longest_sv);
- DECLARE_AND_GET_RE_DEBUG_FLAGS;
+ U32 count = RExC_rxi->data ? RExC_rxi->data->count : 1;
- PERL_ARGS_ASSERT_SCAN_COMMIT;
-
- if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
- const U8 i = data->cur_is_floating;
- SvSetMagicSV(longest_sv, data->last_found);
- data->substrs[i].min_offset = l ? data->last_start_min : data->pos_min;
-
- if (!i) /* fixed */
- data->substrs[0].max_offset = data->substrs[0].min_offset;
- else { /* float */
- data->substrs[1].max_offset =
- (is_inf)
- ? OPTIMIZE_INFTY
- : (l
- ? data->last_start_max
- /* temporary underflow guard for 5.32 */
- : data->pos_delta < 0 ? OPTIMIZE_INFTY
- : (data->pos_delta > OPTIMIZE_INFTY - data->pos_min
- ? OPTIMIZE_INFTY
- : data->pos_min + data->pos_delta));
- }
-
- data->substrs[i].flags &= ~SF_BEFORE_EOL;
- data->substrs[i].flags |= data->flags & SF_BEFORE_EOL;
- data->substrs[i].minlenp = minlenp;
- data->substrs[i].lookbehind = 0;
- }
+ PERL_ARGS_ASSERT_REG_ADD_DATA;
- SvCUR_set(data->last_found, 0);
- {
- SV * const sv = data->last_found;
- if (SvUTF8(sv) && SvMAGICAL(sv)) {
- MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
- if (mg)
- mg->mg_len = 0;
- }
+ /* in the below expression we have (count + n - 1), the minus one is there
+ * because the struct that we allocate already contains a slot for 1 data
+ * item, so we do not need to allocate it the first time. IOW, the
+ * sizeof(*RExC_rxi->data) already accounts for one of the elements we need
+ * to allocate. See struct reg_data in regcomp.h
+ */
+ Renewc(RExC_rxi->data,
+ sizeof(*RExC_rxi->data) + (sizeof(void*) * (count + n - 1)),
+ char, struct reg_data);
+ /* however in the data->what expression we use (count + n) and do not
+ * subtract one from the result because the data structure contains a
+ * pointer to an array, and does not allocate the first element as part of
+ * the data struct. */
+ if (count > 1)
+ Renew(RExC_rxi->data->what, (count + n), U8);
+ else {
+ /* when count == 1 it means we have not initialized anything.
+ * we always fill the 0 slot of the data array with a '%' entry, which
+ * means "zero" (all the other types are letters) which exists purely
+ * so the return from reg_add_data is ALWAYS true, so we can tell it apart
+ * from a "no value" idx=0 in places where we would return an index
+ * into reg_add_data. This is particularly important with the new "single
+ * pass, usually, but not always" strategy that we use, where the code
+ * will use a 0 to represent "not able to compute this yet".
+ */
+ Newx(RExC_rxi->data->what, n+1, U8);
+ /* fill in the placeholder slot of 0 with a what of '%', we use
+ * this because it sorta looks like a zero (0/0) and it is not a letter
+ * like any of the other "whats", this type should never be created
+ * any other way but here. '%' happens to also not appear in this
+ * file for any other reason (at the time of writing this comment)*/
+ RExC_rxi->data->what[0]= '%';
+ RExC_rxi->data->data[0]= NULL;
}
- data->last_end = -1;
- data->flags &= ~SF_BEFORE_EOL;
- DEBUG_STUDYDATA("commit", data, 0, is_inf);
+ RExC_rxi->data->count = count + n;
+ Copy(s, RExC_rxi->data->what + count, n, U8);
+ assert(count>0);
+ return count;
}
+#endif /* PERL_RE_BUILD_AUX */
-/* An SSC is just a regnode_charclass_posix with an extra field: the inversion
- * list that describes which code points it matches */
-
-STATIC void
-S_ssc_anything(pTHX_ regnode_ssc *ssc)
+/*XXX: todo make this not included in a non debugging perl, but appears to be
+ * used anyway there, in 'use re' */
+#ifndef PERL_IN_XSUB_RE
+void
+Perl_reginitcolors(pTHX)
{
- /* Set the SSC 'ssc' to match an empty string or any code point */
-
- PERL_ARGS_ASSERT_SSC_ANYTHING;
-
- assert(is_ANYOF_SYNTHETIC(ssc));
-
- /* mortalize so won't leak */
- ssc->invlist = sv_2mortal(_add_range_to_invlist(NULL, 0, UV_MAX));
- ANYOF_FLAGS(ssc) |= SSC_MATCHES_EMPTY_STRING; /* Plus matches empty */
+ const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
+ if (s) {
+ char *t = savepv(s);
+ int i = 0;
+ PL_colors[0] = t;
+ while (++i < 6) {
+ t = strchr(t, '\t');
+ if (t) {
+ *t = '\0';
+ PL_colors[i] = ++t;
+ }
+ else
+ PL_colors[i] = t = (char *)"";
+ }
+ } else {
+ int i = 0;
+ while (i < 6)
+ PL_colors[i++] = (char *)"";
+ }
+ PL_colorset = 1;
}
+#endif
-STATIC int
-S_ssc_is_anything(const regnode_ssc *ssc)
-{
- /* Returns TRUE if the SSC 'ssc' can match the empty string and any code
- * point; FALSE otherwise. Thus, this is used to see if using 'ssc' buys
- * us anything: if the function returns TRUE, 'ssc' hasn't been restricted
- * in any way, so there's no point in using it */
-
- UV start, end;
- bool ret;
-
- PERL_ARGS_ASSERT_SSC_IS_ANYTHING;
- assert(is_ANYOF_SYNTHETIC(ssc));
+#ifdef TRIE_STUDY_OPT
+/* search for "restudy" in this file for a detailed explanation */
+#define CHECK_RESTUDY_GOTO_butfirst(dOsomething) \
+ STMT_START { \
+ if ( \
+ (data.flags & SCF_TRIE_RESTUDY) \
+ && ! restudied++ \
+ ) { \
+ dOsomething; \
+ goto reStudy; \
+ } \
+ } STMT_END
+#else
+#define CHECK_RESTUDY_GOTO_butfirst
+#endif
- if (! (ANYOF_FLAGS(ssc) & SSC_MATCHES_EMPTY_STRING)) {
- return FALSE;
- }
+/*
+ * pregcomp - compile a regular expression into internal code
+ *
+ * Decides which engine's compiler to call based on the hint currently in
+ * scope
+ */
- /* See if the list consists solely of the range 0 - Infinity */
- invlist_iterinit(ssc->invlist);
- ret = invlist_iternext(ssc->invlist, &start, &end)
- && start == 0
- && end == UV_MAX;
+#ifndef PERL_IN_XSUB_RE
- invlist_iterfinish(ssc->invlist);
+/* return the currently in-scope regex engine (or the default if none) */
- if (ret) {
- return TRUE;
- }
-
- /* If e.g., both \w and \W are set, matches everything */
- if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
- int i;
- for (i = 0; i < ANYOF_POSIXL_MAX; i += 2) {
- if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i+1)) {
- return TRUE;
- }
- }
- }
-
- return FALSE;
-}
-
-STATIC void
-S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc)
+regexp_engine const *
+Perl_current_re_engine(pTHX)
{
- /* Initializes the SSC 'ssc'. This includes setting it to match an empty
- * string, any code point, or any posix class under locale */
-
- PERL_ARGS_ASSERT_SSC_INIT;
-
- Zero(ssc, 1, regnode_ssc);
- set_ANYOF_SYNTHETIC(ssc);
- ARG_SET(ssc, ANYOF_ONLY_HAS_BITMAP);
- ssc_anything(ssc);
-
- /* If any portion of the regex is to operate under locale rules that aren't
- * fully known at compile time, initialization includes it. The reason
- * this isn't done for all regexes is that the optimizer was written under
- * the assumption that locale was all-or-nothing. Given the complexity and
- * lack of documentation in the optimizer, and that there are inadequate
- * test cases for locale, many parts of it may not work properly, it is
- * safest to avoid locale unless necessary. */
- if (RExC_contains_locale) {
- ANYOF_POSIXL_SETALL(ssc);
+ if (IN_PERL_COMPILETIME) {
+ HV * const table = GvHV(PL_hintgv);
+ SV **ptr;
+
+ if (!table || !(PL_hints & HINT_LOCALIZE_HH))
+ return &PL_core_reg_engine;
+ ptr = hv_fetchs(table, "regcomp", FALSE);
+ if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
+ return &PL_core_reg_engine;
+ return INT2PTR(regexp_engine*, SvIV(*ptr));
}
else {
- ANYOF_POSIXL_ZERO(ssc);
+ SV *ptr;
+ if (!PL_curcop->cop_hints_hash)
+ return &PL_core_reg_engine;
+ ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
+ if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
+ return &PL_core_reg_engine;
+ return INT2PTR(regexp_engine*, SvIV(ptr));
}
}
-STATIC int
-S_ssc_is_cp_posixl_init(const RExC_state_t *pRExC_state,
- const regnode_ssc *ssc)
+
+REGEXP *
+Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
{
- /* Returns TRUE if the SSC 'ssc' is in its initial state with regard only
- * to the list of code points matched, and locale posix classes; hence does
- * not check its flags) */
+ regexp_engine const *eng = current_re_engine();
+ DECLARE_AND_GET_RE_DEBUG_FLAGS;
- UV start, end;
- bool ret;
+ PERL_ARGS_ASSERT_PREGCOMP;
- PERL_ARGS_ASSERT_SSC_IS_CP_POSIXL_INIT;
+ /* Dispatch a request to compile a regexp to correct regexp engine. */
+ DEBUG_COMPILE_r({
+ Perl_re_printf( aTHX_ "Using engine %" UVxf "\n",
+ PTR2UV(eng));
+ });
+ return CALLREGCOMP_ENG(eng, pattern, flags);
+}
+#endif
- assert(is_ANYOF_SYNTHETIC(ssc));
+/*
+=for apidoc re_compile
- invlist_iterinit(ssc->invlist);
- ret = invlist_iternext(ssc->invlist, &start, &end)
- && start == 0
- && end == UV_MAX;
+Compile the regular expression pattern C<pattern>, returning a pointer to the
+compiled object for later matching with the internal regex engine.
- invlist_iterfinish(ssc->invlist);
+This function is typically used by a custom regexp engine C<.comp()> function
+to hand off to the core regexp engine those patterns it doesn't want to handle
+itself (typically passing through the same flags it was called with). In
+almost all other cases, a regexp should be compiled by calling L</C<pregcomp>>
+to compile using the currently active regexp engine.
- if (! ret) {
- return FALSE;
- }
+If C<pattern> is already a C<REGEXP>, this function does nothing but return a
+pointer to the input. Otherwise the PV is extracted and treated like a string
+representing a pattern. See L<perlre>.
- if (RExC_contains_locale && ! ANYOF_POSIXL_SSC_TEST_ALL_SET(ssc)) {
- return FALSE;
- }
+The possible flags for C<rx_flags> are documented in L<perlreapi>. Their names
+all begin with C<RXf_>.
- return TRUE;
-}
+=cut
-#define INVLIST_INDEX 0
-#define ONLY_LOCALE_MATCHES_INDEX 1
-#define DEFERRED_USER_DEFINED_INDEX 2
+ * public entry point for the perl core's own regex compiling code.
+ * It's actually a wrapper for Perl_re_op_compile that only takes an SV
+ * pattern rather than a list of OPs, and uses the internal engine rather
+ * than the current one */
-STATIC SV*
-S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state,
- const regnode_charclass* const node)
+REGEXP *
+Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
{
- /* Returns a mortal inversion list defining which code points are matched
- * by 'node', which is of type ANYOF. Handles complementing the result if
- * appropriate. If some code points aren't knowable at this time, the
- * returned list must, and will, contain every code point that is a
- * possibility. */
-
- SV* invlist = NULL;
- SV* only_utf8_locale_invlist = NULL;
- unsigned int i;
- const U32 n = ARG(node);
- bool new_node_has_latin1 = FALSE;
- const U8 flags = (inRANGE(OP(node), ANYOFH, ANYOFRb))
- ? 0
- : ANYOF_FLAGS(node);
-
- PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC;
-
- /* Look at the data structure created by S_set_ANYOF_arg() */
- if (n != ANYOF_ONLY_HAS_BITMAP) {
- SV * const rv = MUTABLE_SV(RExC_rxi->data->data[n]);
- AV * const av = MUTABLE_AV(SvRV(rv));
- SV **const ary = AvARRAY(av);
- assert(RExC_rxi->data->what[n] == 's');
+ SV *pat = pattern; /* defeat constness! */
- if (av_tindex_skip_len_mg(av) >= DEFERRED_USER_DEFINED_INDEX) {
+ PERL_ARGS_ASSERT_RE_COMPILE;
- /* Here there are things that won't be known until runtime -- we
- * have to assume it could be anything */
- invlist = sv_2mortal(_new_invlist(1));
- return _add_range_to_invlist(invlist, 0, UV_MAX);
- }
- else if (ary[INVLIST_INDEX]) {
+ return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
+#ifdef PERL_IN_XSUB_RE
+ &my_reg_engine,
+#else
+ &PL_core_reg_engine,
+#endif
+ NULL, NULL, rx_flags, 0);
+}
- /* Use the node's inversion list */
- invlist = sv_2mortal(invlist_clone(ary[INVLIST_INDEX], NULL));
- }
+static void
+S_free_codeblocks(pTHX_ struct reg_code_blocks *cbs)
+{
+ int n;
- /* Get the code points valid only under UTF-8 locales */
- if ( (flags & ANYOFL_FOLD)
- && av_tindex_skip_len_mg(av) >= ONLY_LOCALE_MATCHES_INDEX)
- {
- only_utf8_locale_invlist = ary[ONLY_LOCALE_MATCHES_INDEX];
+ if (--cbs->refcnt > 0)
+ return;
+ for (n = 0; n < cbs->count; n++) {
+ REGEXP *rx = cbs->cb[n].src_regex;
+ if (rx) {
+ cbs->cb[n].src_regex = NULL;
+ SvREFCNT_dec_NN(rx);
}
}
+ Safefree(cbs->cb);
+ Safefree(cbs);
+}
- if (! invlist) {
- invlist = sv_2mortal(_new_invlist(0));
- }
- /* An ANYOF node contains a bitmap for the first NUM_ANYOF_CODE_POINTS
- * code points, and an inversion list for the others, but if there are code
- * points that should match only conditionally on the target string being
- * UTF-8, those are placed in the inversion list, and not the bitmap.
- * Since there are circumstances under which they could match, they are
- * included in the SSC. But if the ANYOF node is to be inverted, we have
- * to exclude them here, so that when we invert below, the end result
- * actually does include them. (Think about "\xe0" =~ /[^\xc0]/di;). We
- * have to do this here before we add the unconditionally matched code
- * points */
- if (flags & ANYOF_INVERT) {
- _invlist_intersection_complement_2nd(invlist,
- PL_UpperLatin1,
- &invlist);
- }
+static struct reg_code_blocks *
+S_alloc_code_blocks(pTHX_ int ncode)
+{
+ struct reg_code_blocks *cbs;
+ Newx(cbs, 1, struct reg_code_blocks);
+ cbs->count = ncode;
+ cbs->refcnt = 1;
+ SAVEDESTRUCTOR_X(S_free_codeblocks, cbs);
+ if (ncode)
+ Newx(cbs->cb, ncode, struct reg_code_block);
+ else
+ cbs->cb = NULL;
+ return cbs;
+}
- /* Add in the points from the bit map */
- if (! inRANGE(OP(node), ANYOFH, ANYOFRb)) {
- for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
- if (ANYOF_BITMAP_TEST(node, i)) {
- unsigned int start = i++;
- for (; i < NUM_ANYOF_CODE_POINTS
- && ANYOF_BITMAP_TEST(node, i); ++i)
- {
- /* empty */
- }
- invlist = _add_range_to_invlist(invlist, start, i-1);
- new_node_has_latin1 = TRUE;
- }
- }
- }
+/* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
+ * blocks, recalculate the indices. Update pat_p and plen_p in-place to
+ * point to the realloced string and length.
+ *
+ * This is essentially a copy of Perl_bytes_to_utf8() with the code index
+ * stuff added */
- /* If this can match all upper Latin1 code points, have to add them
- * as well. But don't add them if inverting, as when that gets done below,
- * it would exclude all these characters, including the ones it shouldn't
- * that were added just above */
- if (! (flags & ANYOF_INVERT) && OP(node) == ANYOFD
- && (flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER))
- {
- _invlist_union(invlist, PL_UpperLatin1, &invlist);
- }
+static void
+S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
+ char **pat_p, STRLEN *plen_p, int num_code_blocks)
+{
+ U8 *const src = (U8*)*pat_p;
+ U8 *dst, *d;
+ int n=0;
+ STRLEN s = 0;
+ bool do_end = 0;
+ DECLARE_AND_GET_RE_DEBUG_FLAGS;
- /* Similarly for these */
- if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
- _invlist_union_complement_2nd(invlist, PL_InBitmap, &invlist);
- }
+ DEBUG_PARSE_r(Perl_re_printf( aTHX_
+ "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
- if (flags & ANYOF_INVERT) {
- _invlist_invert(invlist);
- }
- else if (flags & ANYOFL_FOLD) {
- if (new_node_has_latin1) {
+ /* 1 for each byte + 1 for each byte that expands to two, + trailing NUL */
+ Newx(dst, *plen_p + variant_under_utf8_count(src, src + *plen_p) + 1, U8);
+ d = dst;
- /* Under /li, any 0-255 could fold to any other 0-255, depending on
- * the locale. We can skip this if there are no 0-255 at all. */
- _invlist_union(invlist, PL_Latin1, &invlist);
+ while (s < *plen_p) {
+ append_utf8_from_native_byte(src[s], &d);
- invlist = add_cp_to_invlist(invlist, LATIN_SMALL_LETTER_DOTLESS_I);
- invlist = add_cp_to_invlist(invlist, LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
- }
- else {
- if (_invlist_contains_cp(invlist, LATIN_SMALL_LETTER_DOTLESS_I)) {
- invlist = add_cp_to_invlist(invlist, 'I');
+ if (n < num_code_blocks) {
+ assert(pRExC_state->code_blocks);
+ if (!do_end && pRExC_state->code_blocks->cb[n].start == s) {
+ pRExC_state->code_blocks->cb[n].start = d - dst - 1;
+ assert(*(d - 1) == '(');
+ do_end = 1;
}
- if (_invlist_contains_cp(invlist,
- LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE))
- {
- invlist = add_cp_to_invlist(invlist, 'i');
+ else if (do_end && pRExC_state->code_blocks->cb[n].end == s) {
+ pRExC_state->code_blocks->cb[n].end = d - dst - 1;
+ assert(*(d - 1) == ')');
+ do_end = 0;
+ n++;
}
}
+ s++;
}
-
- /* Similarly add the UTF-8 locale possible matches. These have to be
- * deferred until after the non-UTF-8 locale ones are taken care of just
- * above, or it leads to wrong results under ANYOF_INVERT */
- if (only_utf8_locale_invlist) {
- _invlist_union_maybe_complement_2nd(invlist,
- only_utf8_locale_invlist,
- flags & ANYOF_INVERT,
- &invlist);
- }
-
- return invlist;
+ *d = '\0';
+ *plen_p = d - dst;
+ *pat_p = (char*) dst;
+ SAVEFREEPV(*pat_p);
+ RExC_orig_utf8 = RExC_utf8 = 1;
}
-/* These two functions currently do the exact same thing */
-#define ssc_init_zero ssc_init
-#define ssc_add_cp(ssc, cp) ssc_add_range((ssc), (cp), (cp))
-#define ssc_match_all_cp(ssc) ssc_add_range(ssc, 0, UV_MAX)
-/* 'AND' a given class with another one. Can create false positives. 'ssc'
- * should not be inverted. 'and_with->flags & ANYOF_MATCHES_POSIXL' should be
- * 0 if 'and_with' is a regnode_charclass instead of a regnode_ssc. */
+/* S_concat_pat(): concatenate a list of args to the pattern string pat,
+ * while recording any code block indices, and handling overloading,
+ * nested qr// objects etc. If pat is null, it will allocate a new
+ * string, or just return the first arg, if there's only one.
+ *
+ * Returns the malloced/updated pat.
+ * patternp and pat_count is the array of SVs to be concatted;
+ * oplist is the optional list of ops that generated the SVs;
+ * recompile_p is a pointer to a boolean that will be set if
+ * the regex will need to be recompiled.
+ * delim, if non-null is an SV that will be inserted between each element
+ */
-STATIC void
-S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
- const regnode_charclass *and_with)
+static SV*
+S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
+ SV *pat, SV ** const patternp, int pat_count,
+ OP *oplist, bool *recompile_p, SV *delim)
{
- /* Accumulate into SSC 'ssc' its 'AND' with 'and_with', which is either
- * another SSC or a regular ANYOF class. Can create false positives. */
-
- SV* anded_cp_list;
- U8 and_with_flags = inRANGE(OP(and_with), ANYOFH, ANYOFRb)
- ? 0
- : ANYOF_FLAGS(and_with);
- U8 anded_flags;
-
- PERL_ARGS_ASSERT_SSC_AND;
-
- assert(is_ANYOF_SYNTHETIC(ssc));
-
- /* 'and_with' is used as-is if it too is an SSC; otherwise have to extract
- * the code point inversion list and just the relevant flags */
- if (is_ANYOF_SYNTHETIC(and_with)) {
- anded_cp_list = ((regnode_ssc *)and_with)->invlist;
- anded_flags = and_with_flags;
-
- /* XXX This is a kludge around what appears to be deficiencies in the
- * optimizer. If we make S_ssc_anything() add in the WARN_SUPER flag,
- * there are paths through the optimizer where it doesn't get weeded
- * out when it should. And if we don't make some extra provision for
- * it like the code just below, it doesn't get added when it should.
- * This solution is to add it only when AND'ing, which is here, and
- * only when what is being AND'ed is the pristine, original node
- * matching anything. Thus it is like adding it to ssc_anything() but
- * only when the result is to be AND'ed. Probably the same solution
- * could be adopted for the same problem we have with /l matching,
- * which is solved differently in S_ssc_init(), and that would lead to
- * fewer false positives than that solution has. But if this solution
- * creates bugs, the consequences are only that a warning isn't raised
- * that should be; while the consequences for having /l bugs is
- * incorrect matches */
- if (ssc_is_anything((regnode_ssc *)and_with)) {
- anded_flags |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
- }
- }
- else {
- anded_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, and_with);
- if (OP(and_with) == ANYOFD) {
- anded_flags = and_with_flags & ANYOF_COMMON_FLAGS;
- }
- else {
- anded_flags = and_with_flags
- &( ANYOF_COMMON_FLAGS
- |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
- |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
- if (ANYOFL_UTF8_LOCALE_REQD(and_with_flags)) {
- anded_flags &=
- ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
- }
- }
- }
-
- ANYOF_FLAGS(ssc) &= anded_flags;
-
- /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
- * C2 is the list of code points in 'and-with'; P2, its posix classes.
- * 'and_with' may be inverted. When not inverted, we have the situation of
- * computing:
- * (C1 | P1) & (C2 | P2)
- * = (C1 & (C2 | P2)) | (P1 & (C2 | P2))
- * = ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
- * <= ((C1 & C2) | P2)) | ( P1 | (P1 & P2))
- * <= ((C1 & C2) | P1 | P2)
- * Alternatively, the last few steps could be:
- * = ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
- * <= ((C1 & C2) | C1 ) | ( C2 | (P1 & P2))
- * <= (C1 | C2 | (P1 & P2))
- * We favor the second approach if either P1 or P2 is non-empty. This is
- * because these components are a barrier to doing optimizations, as what
- * they match cannot be known until the moment of matching as they are
- * dependent on the current locale, 'AND"ing them likely will reduce or
- * eliminate them.
- * But we can do better if we know that C1,P1 are in their initial state (a
- * frequent occurrence), each matching everything:
- * (<everything>) & (C2 | P2) = C2 | P2
- * Similarly, if C2,P2 are in their initial state (again a frequent
- * occurrence), the result is a no-op
- * (C1 | P1) & (<everything>) = C1 | P1
- *
- * Inverted, we have
- * (C1 | P1) & ~(C2 | P2) = (C1 | P1) & (~C2 & ~P2)
- * = (C1 & (~C2 & ~P2)) | (P1 & (~C2 & ~P2))
- * <= (C1 & ~C2) | (P1 & ~P2)
- * */
+ SV **svp;
+ int n = 0;
+ bool use_delim = FALSE;
+ bool alloced = FALSE;
- if ((and_with_flags & ANYOF_INVERT)
- && ! is_ANYOF_SYNTHETIC(and_with))
- {
- unsigned int i;
-
- ssc_intersection(ssc,
- anded_cp_list,
- FALSE /* Has already been inverted */
- );
-
- /* If either P1 or P2 is empty, the intersection will be also; can skip
- * the loop */
- if (! (and_with_flags & ANYOF_MATCHES_POSIXL)) {
- ANYOF_POSIXL_ZERO(ssc);
- }
- else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
-
- /* Note that the Posix class component P from 'and_with' actually
- * looks like:
- * P = Pa | Pb | ... | Pn
- * where each component is one posix class, such as in [\w\s].
- * Thus
- * ~P = ~(Pa | Pb | ... | Pn)
- * = ~Pa & ~Pb & ... & ~Pn
- * <= ~Pa | ~Pb | ... | ~Pn
- * The last is something we can easily calculate, but unfortunately
- * is likely to have many false positives. We could do better
- * in some (but certainly not all) instances if two classes in
- * P have known relationships. For example
- * :lower: <= :alpha: <= :alnum: <= \w <= :graph: <= :print:
- * So
- * :lower: & :print: = :lower:
- * And similarly for classes that must be disjoint. For example,
- * since \s and \w can have no elements in common based on rules in
- * the POSIX standard,
- * \w & ^\S = nothing
- * Unfortunately, some vendor locales do not meet the Posix
- * standard, in particular almost everything by Microsoft.
- * The loop below just changes e.g., \w into \W and vice versa */
-
- regnode_charclass_posixl temp;
- int add = 1; /* To calculate the index of the complement */
-
- Zero(&temp, 1, regnode_charclass_posixl);
- ANYOF_POSIXL_ZERO(&temp);
- for (i = 0; i < ANYOF_MAX; i++) {
- assert(i % 2 != 0
- || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)
- || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i + 1));
-
- if (ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)) {
- ANYOF_POSIXL_SET(&temp, i + add);
- }
- add = 0 - add; /* 1 goes to -1; -1 goes to 1 */
- }
- ANYOF_POSIXL_AND(&temp, ssc);
-
- } /* else ssc already has no posixes */
- } /* else: Not inverted. This routine is a no-op if 'and_with' is an SSC
- in its initial state */
- else if (! is_ANYOF_SYNTHETIC(and_with)
- || ! ssc_is_cp_posixl_init(pRExC_state, (regnode_ssc *)and_with))
- {
- /* But if 'ssc' is in its initial state, the result is just 'and_with';
- * copy it over 'ssc' */
- if (ssc_is_cp_posixl_init(pRExC_state, ssc)) {
- if (is_ANYOF_SYNTHETIC(and_with)) {
- StructCopy(and_with, ssc, regnode_ssc);
- }
- else {
- ssc->invlist = anded_cp_list;
- ANYOF_POSIXL_ZERO(ssc);
- if (and_with_flags & ANYOF_MATCHES_POSIXL) {
- ANYOF_POSIXL_OR((regnode_charclass_posixl*) and_with, ssc);
- }
- }
- }
- else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)
- || (and_with_flags & ANYOF_MATCHES_POSIXL))
- {
- /* One or the other of P1, P2 is non-empty. */
- if (and_with_flags & ANYOF_MATCHES_POSIXL) {
- ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc);
- }
- ssc_union(ssc, anded_cp_list, FALSE);
- }
- else { /* P1 = P2 = empty */
- ssc_intersection(ssc, anded_cp_list, FALSE);
- }
+ /* if we know we have at least two args, create an empty string,
+ * then concatenate args to that. For no args, return an empty string */
+ if (!pat && pat_count != 1) {
+ pat = newSVpvs("");
+ SAVEFREESV(pat);
+ alloced = TRUE;
}
-}
-STATIC void
-S_ssc_or(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
- const regnode_charclass *or_with)
-{
- /* Accumulate into SSC 'ssc' its 'OR' with 'or_with', which is either
- * another SSC or a regular ANYOF class. Can create false positives if
- * 'or_with' is to be inverted. */
+ for (svp = patternp; svp < patternp + pat_count; svp++) {
+ SV *sv;
+ SV *rx = NULL;
+ STRLEN orig_patlen = 0;
+ bool code = 0;
+ SV *msv = use_delim ? delim : *svp;
+ if (!msv) msv = &PL_sv_undef;
- SV* ored_cp_list;
- U8 ored_flags;
- U8 or_with_flags = inRANGE(OP(or_with), ANYOFH, ANYOFRb)
- ? 0
- : ANYOF_FLAGS(or_with);
+ /* if we've got a delimiter, we go round the loop twice for each
+ * svp slot (except the last), using the delimiter the second
+ * time round */
+ if (use_delim) {
+ svp--;
+ use_delim = FALSE;
+ }
+ else if (delim)
+ use_delim = TRUE;
- PERL_ARGS_ASSERT_SSC_OR;
+ if (SvTYPE(msv) == SVt_PVAV) {
+ /* we've encountered an interpolated array within
+ * the pattern, e.g. /...@a..../. Expand the list of elements,
+ * then recursively append elements.
+ * The code in this block is based on S_pushav() */
- assert(is_ANYOF_SYNTHETIC(ssc));
+ AV *const av = (AV*)msv;
+ const SSize_t maxarg = AvFILL(av) + 1;
+ SV **array;
- /* 'or_with' is used as-is if it too is an SSC; otherwise have to extract
- * the code point inversion list and just the relevant flags */
- if (is_ANYOF_SYNTHETIC(or_with)) {
- ored_cp_list = ((regnode_ssc*) or_with)->invlist;
- ored_flags = or_with_flags;
- }
- else {
- ored_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, or_with);
- ored_flags = or_with_flags & ANYOF_COMMON_FLAGS;
- if (OP(or_with) != ANYOFD) {
- ored_flags
- |= or_with_flags
- & ( ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
- |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
- if (ANYOFL_UTF8_LOCALE_REQD(or_with_flags)) {
- ored_flags |=
- ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
+ if (oplist) {
+ assert(oplist->op_type == OP_PADAV
+ || oplist->op_type == OP_RV2AV);
+ oplist = OpSIBLING(oplist);
}
- }
- }
- ANYOF_FLAGS(ssc) |= ored_flags;
-
- /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
- * C2 is the list of code points in 'or-with'; P2, its posix classes.
- * 'or_with' may be inverted. When not inverted, we have the simple
- * situation of computing:
- * (C1 | P1) | (C2 | P2) = (C1 | C2) | (P1 | P2)
- * If P1|P2 yields a situation with both a class and its complement are
- * set, like having both \w and \W, this matches all code points, and we
- * can delete these from the P component of the ssc going forward. XXX We
- * might be able to delete all the P components, but I (khw) am not certain
- * about this, and it is better to be safe.
- *
- * Inverted, we have
- * (C1 | P1) | ~(C2 | P2) = (C1 | P1) | (~C2 & ~P2)
- * <= (C1 | P1) | ~C2
- * <= (C1 | ~C2) | P1
- * (which results in actually simpler code than the non-inverted case)
- * */
+ if (SvRMAGICAL(av)) {
+ SSize_t i;
- if ((or_with_flags & ANYOF_INVERT)
- && ! is_ANYOF_SYNTHETIC(or_with))
- {
- /* We ignore P2, leaving P1 going forward */
- } /* else Not inverted */
- else if (or_with_flags & ANYOF_MATCHES_POSIXL) {
- ANYOF_POSIXL_OR((regnode_charclass_posixl*)or_with, ssc);
- if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
- unsigned int i;
- for (i = 0; i < ANYOF_MAX; i += 2) {
- if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i + 1))
- {
- ssc_match_all_cp(ssc);
- ANYOF_POSIXL_CLEAR(ssc, i);
- ANYOF_POSIXL_CLEAR(ssc, i+1);
+ Newx(array, maxarg, SV*);
+ SAVEFREEPV(array);
+ for (i=0; i < maxarg; i++) {
+ SV ** const svp = av_fetch(av, i, FALSE);
+ array[i] = svp ? *svp : &PL_sv_undef;
}
}
- }
- }
+ else
+ array = AvARRAY(av);
- ssc_union(ssc,
- ored_cp_list,
- FALSE /* Already has been inverted */
- );
-}
+ if (maxarg > 0) {
+ pat = S_concat_pat(aTHX_ pRExC_state, pat,
+ array, maxarg, NULL, recompile_p,
+ /* $" */
+ GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV))));
+ }
+ else if (!pat) {
+ pat = newSVpvs_flags("", SVs_TEMP);
+ }
-STATIC void
-S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, const bool invert2nd)
-{
- PERL_ARGS_ASSERT_SSC_UNION;
+ continue;
+ }
- assert(is_ANYOF_SYNTHETIC(ssc));
- _invlist_union_maybe_complement_2nd(ssc->invlist,
- invlist,
- invert2nd,
- &ssc->invlist);
-}
-
-STATIC void
-S_ssc_intersection(pTHX_ regnode_ssc *ssc,
- SV* const invlist,
- const bool invert2nd)
-{
- PERL_ARGS_ASSERT_SSC_INTERSECTION;
-
- assert(is_ANYOF_SYNTHETIC(ssc));
-
- _invlist_intersection_maybe_complement_2nd(ssc->invlist,
- invlist,
- invert2nd,
- &ssc->invlist);
-}
-
-STATIC void
-S_ssc_add_range(pTHX_ regnode_ssc *ssc, const UV start, const UV end)
-{
- PERL_ARGS_ASSERT_SSC_ADD_RANGE;
-
- assert(is_ANYOF_SYNTHETIC(ssc));
-
- ssc->invlist = _add_range_to_invlist(ssc->invlist, start, end);
-}
-
-STATIC void
-S_ssc_cp_and(pTHX_ regnode_ssc *ssc, const UV cp)
-{
- /* AND just the single code point 'cp' into the SSC 'ssc' */
-
- SV* cp_list = _new_invlist(2);
-
- PERL_ARGS_ASSERT_SSC_CP_AND;
-
- assert(is_ANYOF_SYNTHETIC(ssc));
-
- cp_list = add_cp_to_invlist(cp_list, cp);
- ssc_intersection(ssc, cp_list,
- FALSE /* Not inverted */
- );
- SvREFCNT_dec_NN(cp_list);
-}
-
-STATIC void
-S_ssc_clear_locale(regnode_ssc *ssc)
-{
- /* Set the SSC 'ssc' to not match any locale things */
- PERL_ARGS_ASSERT_SSC_CLEAR_LOCALE;
-
- assert(is_ANYOF_SYNTHETIC(ssc));
-
- ANYOF_POSIXL_ZERO(ssc);
- ANYOF_FLAGS(ssc) &= ~ANYOF_LOCALE_FLAGS;
-}
-
-STATIC bool
-S_is_ssc_worth_it(const RExC_state_t * pRExC_state, const regnode_ssc * ssc)
-{
- /* The synthetic start class is used to hopefully quickly winnow down
- * places where a pattern could start a match in the target string. If it
- * doesn't really narrow things down that much, there isn't much point to
- * having the overhead of using it. This function uses some very crude
- * heuristics to decide if to use the ssc or not.
- *
- * It returns TRUE if 'ssc' rules out more than half what it considers to
- * be the "likely" possible matches, but of course it doesn't know what the
- * actual things being matched are going to be; these are only guesses
- *
- * For /l matches, it assumes that the only likely matches are going to be
- * in the 0-255 range, uniformly distributed, so half of that is 127
- * For /a and /d matches, it assumes that the likely matches will be just
- * the ASCII range, so half of that is 63
- * For /u and there isn't anything matching above the Latin1 range, it
- * assumes that that is the only range likely to be matched, and uses
- * half that as the cut-off: 127. If anything matches above Latin1,
- * it assumes that all of Unicode could match (uniformly), except for
- * non-Unicode code points and things in the General Category "Other"
- * (unassigned, private use, surrogates, controls and formats). This
- * is a much large number. */
-
- U32 count = 0; /* Running total of number of code points matched by
- 'ssc' */
- UV start, end; /* Start and end points of current range in inversion
- XXX outdated. UTF-8 locales are common, what about invert? list */
- const U32 max_code_points = (LOC)
- ? 256
- : (( ! UNI_SEMANTICS
- || invlist_highest(ssc->invlist) < 256)
- ? 128
- : NON_OTHER_COUNT);
- const U32 max_match = max_code_points / 2;
-
- PERL_ARGS_ASSERT_IS_SSC_WORTH_IT;
-
- invlist_iterinit(ssc->invlist);
- while (invlist_iternext(ssc->invlist, &start, &end)) {
- if (start >= max_code_points) {
- break;
- }
- end = MIN(end, max_code_points - 1);
- count += end - start + 1;
- if (count >= max_match) {
- invlist_iterfinish(ssc->invlist);
- return FALSE;
- }
- }
-
- return TRUE;
-}
-
-
-STATIC void
-S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc)
-{
- /* The inversion list in the SSC is marked mortal; now we need a more
- * permanent copy, which is stored the same way that is done in a regular
- * ANYOF node, with the first NUM_ANYOF_CODE_POINTS code points in a bit
- * map */
-
- SV* invlist = invlist_clone(ssc->invlist, NULL);
-
- PERL_ARGS_ASSERT_SSC_FINALIZE;
-
- assert(is_ANYOF_SYNTHETIC(ssc));
-
- /* The code in this file assumes that all but these flags aren't relevant
- * to the SSC, except SSC_MATCHES_EMPTY_STRING, which should be cleared
- * by the time we reach here */
- assert(! (ANYOF_FLAGS(ssc)
- & ~( ANYOF_COMMON_FLAGS
- |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
- |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)));
-
- populate_ANYOF_from_invlist( (regnode *) ssc, &invlist);
-
- set_ANYOF_arg(pRExC_state, (regnode *) ssc, invlist, NULL, NULL);
- SvREFCNT_dec(invlist);
-
- /* Make sure is clone-safe */
- ssc->invlist = NULL;
-
- if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
- ANYOF_FLAGS(ssc) |= ANYOF_MATCHES_POSIXL;
- OP(ssc) = ANYOFPOSIXL;
- }
- else if (RExC_contains_locale) {
- OP(ssc) = ANYOFL;
- }
-
- assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE_FLAGS) || RExC_contains_locale);
-}
-
-#define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
-#define TRIE_LIST_CUR(state) ( TRIE_LIST_ITEM( state, 0 ).forid )
-#define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
-#define TRIE_LIST_USED(idx) ( trie->states[state].trans.list \
- ? (TRIE_LIST_CUR( idx ) - 1) \
- : 0 )
-
-
-#ifdef DEBUGGING
-/*
- dump_trie(trie,widecharmap,revcharmap)
- dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
- dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
-
- These routines dump out a trie in a somewhat readable format.
- The _interim_ variants are used for debugging the interim
- tables that are used to generate the final compressed
- representation which is what dump_trie expects.
-
- Part of the reason for their existence is to provide a form
- of documentation as to how the different representations function.
-
-*/
-
-/*
- Dumps the final compressed table form of the trie to Perl_debug_log.
- Used for debugging make_trie().
-*/
-
-STATIC void
-S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
- AV *revcharmap, U32 depth)
-{
- U32 state;
- SV *sv=sv_newmortal();
- int colwidth= widecharmap ? 6 : 4;
- U16 word;
- DECLARE_AND_GET_RE_DEBUG_FLAGS;
-
- PERL_ARGS_ASSERT_DUMP_TRIE;
-
- Perl_re_indentf( aTHX_ "Char : %-6s%-6s%-4s ",
- depth+1, "Match","Base","Ofs" );
-
- for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
- SV ** const tmp = av_fetch( revcharmap, state, 0);
- if ( tmp ) {
- Perl_re_printf( aTHX_ "%*s",
- colwidth,
- pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
- PL_colors[0], PL_colors[1],
- (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
- PERL_PV_ESCAPE_FIRSTCHAR
- )
- );
- }
- }
- Perl_re_printf( aTHX_ "\n");
- Perl_re_indentf( aTHX_ "State|-----------------------", depth+1);
-
- for( state = 0 ; state < trie->uniquecharcount ; state++ )
- Perl_re_printf( aTHX_ "%.*s", colwidth, "--------");
- Perl_re_printf( aTHX_ "\n");
-
- for( state = 1 ; state < trie->statecount ; state++ ) {
- const U32 base = trie->states[ state ].trans.base;
-
- Perl_re_indentf( aTHX_ "#%4" UVXf "|", depth+1, (UV)state);
-
- if ( trie->states[ state ].wordnum ) {
- Perl_re_printf( aTHX_ " W%4X", trie->states[ state ].wordnum );
- } else {
- Perl_re_printf( aTHX_ "%6s", "" );
- }
-
- Perl_re_printf( aTHX_ " @%4" UVXf " ", (UV)base );
-
- if ( base ) {
- U32 ofs = 0;
-
- while( ( base + ofs < trie->uniquecharcount ) ||
- ( base + ofs - trie->uniquecharcount < trie->lasttrans
- && trie->trans[ base + ofs - trie->uniquecharcount ].check
- != state))
- ofs++;
-
- Perl_re_printf( aTHX_ "+%2" UVXf "[ ", (UV)ofs);
-
- for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
- if ( ( base + ofs >= trie->uniquecharcount )
- && ( base + ofs - trie->uniquecharcount
- < trie->lasttrans )
- && trie->trans[ base + ofs
- - trie->uniquecharcount ].check == state )
- {
- Perl_re_printf( aTHX_ "%*" UVXf, colwidth,
- (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next
- );
- } else {
- Perl_re_printf( aTHX_ "%*s", colwidth," ." );
- }
- }
-
- Perl_re_printf( aTHX_ "]");
-
- }
- Perl_re_printf( aTHX_ "\n" );
- }
- Perl_re_indentf( aTHX_ "word_info N:(prev,len)=",
- depth);
- for (word=1; word <= trie->wordcount; word++) {
- Perl_re_printf( aTHX_ " %d:(%d,%d)",
- (int)word, (int)(trie->wordinfo[word].prev),
- (int)(trie->wordinfo[word].len));
- }
- Perl_re_printf( aTHX_ "\n" );
-}
-/*
- Dumps a fully constructed but uncompressed trie in list form.
- List tries normally only are used for construction when the number of
- possible chars (trie->uniquecharcount) is very high.
- Used for debugging make_trie().
-*/
-STATIC void
-S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
- HV *widecharmap, AV *revcharmap, U32 next_alloc,
- U32 depth)
-{
- U32 state;
- SV *sv=sv_newmortal();
- int colwidth= widecharmap ? 6 : 4;
- DECLARE_AND_GET_RE_DEBUG_FLAGS;
-
- PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
-
- /* print out the table precompression. */
- Perl_re_indentf( aTHX_ "State :Word | Transition Data\n",
- depth+1 );
- Perl_re_indentf( aTHX_ "%s",
- depth+1, "------:-----+-----------------\n" );
-
- for( state=1 ; state < next_alloc ; state ++ ) {
- U16 charid;
-
- Perl_re_indentf( aTHX_ " %4" UVXf " :",
- depth+1, (UV)state );
- if ( ! trie->states[ state ].wordnum ) {
- Perl_re_printf( aTHX_ "%5s| ","");
- } else {
- Perl_re_printf( aTHX_ "W%4x| ",
- trie->states[ state ].wordnum
- );
- }
- for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
- SV ** const tmp = av_fetch( revcharmap,
- TRIE_LIST_ITEM(state, charid).forid, 0);
- if ( tmp ) {
- Perl_re_printf( aTHX_ "%*s:%3X=%4" UVXf " | ",
- colwidth,
- pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp),
- colwidth,
- PL_colors[0], PL_colors[1],
- (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
- | PERL_PV_ESCAPE_FIRSTCHAR
- ) ,
- TRIE_LIST_ITEM(state, charid).forid,
- (UV)TRIE_LIST_ITEM(state, charid).newstate
- );
- if (!(charid % 10))
- Perl_re_printf( aTHX_ "\n%*s| ",
- (int)((depth * 2) + 14), "");
- }
- }
- Perl_re_printf( aTHX_ "\n");
- }
-}
-
-/*
- Dumps a fully constructed but uncompressed trie in table form.
- This is the normal DFA style state transition table, with a few
- twists to facilitate compression later.
- Used for debugging make_trie().
-*/
-STATIC void
-S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
- HV *widecharmap, AV *revcharmap, U32 next_alloc,
- U32 depth)
-{
- U32 state;
- U16 charid;
- SV *sv=sv_newmortal();
- int colwidth= widecharmap ? 6 : 4;
- DECLARE_AND_GET_RE_DEBUG_FLAGS;
-
- PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
-
- /*
- print out the table precompression so that we can do a visual check
- that they are identical.
- */
-
- Perl_re_indentf( aTHX_ "Char : ", depth+1 );
-
- for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
- SV ** const tmp = av_fetch( revcharmap, charid, 0);
- if ( tmp ) {
- Perl_re_printf( aTHX_ "%*s",
- colwidth,
- pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
- PL_colors[0], PL_colors[1],
- (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
- PERL_PV_ESCAPE_FIRSTCHAR
- )
- );
- }
- }
-
- Perl_re_printf( aTHX_ "\n");
- Perl_re_indentf( aTHX_ "State+-", depth+1 );
-
- for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
- Perl_re_printf( aTHX_ "%.*s", colwidth,"--------");
- }
-
- Perl_re_printf( aTHX_ "\n" );
-
- for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
-
- Perl_re_indentf( aTHX_ "%4" UVXf " : ",
- depth+1,
- (UV)TRIE_NODENUM( state ) );
-
- for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
- UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
- if (v)
- Perl_re_printf( aTHX_ "%*" UVXf, colwidth, v );
- else
- Perl_re_printf( aTHX_ "%*s", colwidth, "." );
- }
- if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
- Perl_re_printf( aTHX_ " (%4" UVXf ")\n",
- (UV)trie->trans[ state ].check );
- } else {
- Perl_re_printf( aTHX_ " (%4" UVXf ") W%4X\n",
- (UV)trie->trans[ state ].check,
- trie->states[ TRIE_NODENUM( state ) ].wordnum );
- }
- }
-}
-
-#endif
-
-
-/* make_trie(startbranch,first,last,tail,word_count,flags,depth)
- startbranch: the first branch in the whole branch sequence
- first : start branch of sequence of branch-exact nodes.
- May be the same as startbranch
- last : Thing following the last branch.
- May be the same as tail.
- tail : item following the branch sequence
- count : words in the sequence
- flags : currently the OP() type we will be building one of /EXACT(|F|FA|FU|FU_SS|L|FLU8)/
- depth : indent depth
-
-Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
-
-A trie is an N'ary tree where the branches are determined by digital
-decomposition of the key. IE, at the root node you look up the 1st character and
-follow that branch repeat until you find the end of the branches. Nodes can be
-marked as "accepting" meaning they represent a complete word. Eg:
-
- /he|she|his|hers/
-
-would convert into the following structure. Numbers represent states, letters
-following numbers represent valid transitions on the letter from that state, if
-the number is in square brackets it represents an accepting state, otherwise it
-will be in parenthesis.
-
- +-h->+-e->[3]-+-r->(8)-+-s->[9]
- | |
- | (2)
- | |
- (1) +-i->(6)-+-s->[7]
- |
- +-s->(3)-+-h->(4)-+-e->[5]
-
- Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
-
-This shows that when matching against the string 'hers' we will begin at state 1
-read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
-then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
-is also accepting. Thus we know that we can match both 'he' and 'hers' with a
-single traverse. We store a mapping from accepting to state to which word was
-matched, and then when we have multiple possibilities we try to complete the
-rest of the regex in the order in which they occurred in the alternation.
-
-The only prior NFA like behaviour that would be changed by the TRIE support is
-the silent ignoring of duplicate alternations which are of the form:
-
- / (DUPE|DUPE) X? (?{ ... }) Y /x
-
-Thus EVAL blocks following a trie may be called a different number of times with
-and without the optimisation. With the optimisations dupes will be silently
-ignored. This inconsistent behaviour of EVAL type nodes is well established as
-the following demonstrates:
-
- 'words'=~/(word|word|word)(?{ print $1 })[xyz]/
-
-which prints out 'word' three times, but
-
- 'words'=~/(word|word|word)(?{ print $1 })S/
-
-which doesnt print it out at all. This is due to other optimisations kicking in.
-
-Example of what happens on a structural level:
-
-The regexp /(ac|ad|ab)+/ will produce the following debug output:
-
- 1: CURLYM[1] {1,32767}(18)
- 5: BRANCH(8)
- 6: EXACT <ac>(16)
- 8: BRANCH(11)
- 9: EXACT <ad>(16)
- 11: BRANCH(14)
- 12: EXACT <ab>(16)
- 16: SUCCEED(0)
- 17: NOTHING(18)
- 18: END(0)
-
-This would be optimizable with startbranch=5, first=5, last=16, tail=16
-and should turn into:
-
- 1: CURLYM[1] {1,32767}(18)
- 5: TRIE(16)
- [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
- <ac>
- <ad>
- <ab>
- 16: SUCCEED(0)
- 17: NOTHING(18)
- 18: END(0)
-
-Cases where tail != last would be like /(?foo|bar)baz/:
-
- 1: BRANCH(4)
- 2: EXACT <foo>(8)
- 4: BRANCH(7)
- 5: EXACT <bar>(8)
- 7: TAIL(8)
- 8: EXACT <baz>(10)
- 10: END(0)
-
-which would be optimizable with startbranch=1, first=1, last=7, tail=8
-and would end up looking like:
-
- 1: TRIE(8)
- [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
- <foo>
- <bar>
- 7: TAIL(8)
- 8: EXACT <baz>(10)
- 10: END(0)
-
- d = uvchr_to_utf8_flags(d, uv, 0);
-
-is the recommended Unicode-aware way of saying
-
- *(d++) = uv;
-*/
-
-#define TRIE_STORE_REVCHAR(val) \
- STMT_START { \
- if (UTF) { \
- SV *zlopp = newSV(UTF8_MAXBYTES); \
- unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp); \
- unsigned char *const kapow = uvchr_to_utf8(flrbbbbb, val); \
- *kapow = '\0'; \
- SvCUR_set(zlopp, kapow - flrbbbbb); \
- SvPOK_on(zlopp); \
- SvUTF8_on(zlopp); \
- av_push(revcharmap, zlopp); \
- } else { \
- char ooooff = (char)val; \
- av_push(revcharmap, newSVpvn(&ooooff, 1)); \
- } \
- } STMT_END
-
-/* This gets the next character from the input, folding it if not already
- * folded. */
-#define TRIE_READ_CHAR STMT_START { \
- wordlen++; \
- if ( UTF ) { \
- /* if it is UTF then it is either already folded, or does not need \
- * folding */ \
- uvc = valid_utf8_to_uvchr( (const U8*) uc, &len); \
- } \
- else if (folder == PL_fold_latin1) { \
- /* This folder implies Unicode rules, which in the range expressible \
- * by not UTF is the lower case, with the two exceptions, one of \
- * which should have been taken care of before calling this */ \
- assert(*uc != LATIN_SMALL_LETTER_SHARP_S); \
- uvc = toLOWER_L1(*uc); \
- if (UNLIKELY(uvc == MICRO_SIGN)) uvc = GREEK_SMALL_LETTER_MU; \
- len = 1; \
- } else { \
- /* raw data, will be folded later if needed */ \
- uvc = (U32)*uc; \
- len = 1; \
- } \
-} STMT_END
-
-
-
-#define TRIE_LIST_PUSH(state,fid,ns) STMT_START { \
- if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) { \
- U32 ging = TRIE_LIST_LEN( state ) * 2; \
- Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
- TRIE_LIST_LEN( state ) = ging; \
- } \
- TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid; \
- TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns; \
- TRIE_LIST_CUR( state )++; \
-} STMT_END
-
-#define TRIE_LIST_NEW(state) STMT_START { \
- Newx( trie->states[ state ].trans.list, \
- 4, reg_trie_trans_le ); \
- TRIE_LIST_CUR( state ) = 1; \
- TRIE_LIST_LEN( state ) = 4; \
-} STMT_END
-
-#define TRIE_HANDLE_WORD(state) STMT_START { \
- U16 dupe= trie->states[ state ].wordnum; \
- regnode * const noper_next = regnext( noper ); \
- \
- DEBUG_r({ \
- /* store the word for dumping */ \
- SV* tmp; \
- if (OP(noper) != NOTHING) \
- tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF); \
- else \
- tmp = newSVpvn_utf8( "", 0, UTF ); \
- av_push( trie_words, tmp ); \
- }); \
- \
- curword++; \
- trie->wordinfo[curword].prev = 0; \
- trie->wordinfo[curword].len = wordlen; \
- trie->wordinfo[curword].accept = state; \
- \
- if ( noper_next < tail ) { \
- if (!trie->jump) \
- trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, \
- sizeof(U16) ); \
- trie->jump[curword] = (U16)(noper_next - convert); \
- if (!jumper) \
- jumper = noper_next; \
- if (!nextbranch) \
- nextbranch= regnext(cur); \
- } \
- \
- if ( dupe ) { \
- /* It's a dupe. Pre-insert into the wordinfo[].prev */\
- /* chain, so that when the bits of chain are later */\
- /* linked together, the dups appear in the chain */\
- trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
- trie->wordinfo[dupe].prev = curword; \
- } else { \
- /* we haven't inserted this word yet. */ \
- trie->states[ state ].wordnum = curword; \
- } \
-} STMT_END
-
-
-#define TRIE_TRANS_STATE(state,base,ucharcount,charid,special) \
- ( ( base + charid >= ucharcount \
- && base + charid < ubound \
- && state == trie->trans[ base - ucharcount + charid ].check \
- && trie->trans[ base - ucharcount + charid ].next ) \
- ? trie->trans[ base - ucharcount + charid ].next \
- : ( state==1 ? special : 0 ) \
- )
-
-#define TRIE_BITMAP_SET_FOLDED(trie, uvc, folder) \
-STMT_START { \
- TRIE_BITMAP_SET(trie, uvc); \
- /* store the folded codepoint */ \
- if ( folder ) \
- TRIE_BITMAP_SET(trie, folder[(U8) uvc ]); \
- \
- if ( !UTF ) { \
- /* store first byte of utf8 representation of */ \
- /* variant codepoints */ \
- if (! UVCHR_IS_INVARIANT(uvc)) { \
- TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc)); \
- } \
- } \
-} STMT_END
-#define MADE_TRIE 1
-#define MADE_JUMP_TRIE 2
-#define MADE_EXACT_TRIE 4
-
-STATIC I32
-S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch,
- regnode *first, regnode *last, regnode *tail,
- U32 word_count, U32 flags, U32 depth)
-{
- /* first pass, loop through and scan words */
- reg_trie_data *trie;
- HV *widecharmap = NULL;
- AV *revcharmap = newAV();
- regnode *cur;
- STRLEN len = 0;
- UV uvc = 0;
- U16 curword = 0;
- U32 next_alloc = 0;
- regnode *jumper = NULL;
- regnode *nextbranch = NULL;
- regnode *convert = NULL;
- U32 *prev_states; /* temp array mapping each state to previous one */
- /* we just use folder as a flag in utf8 */
- const U8 * folder = NULL;
-
- /* in the below add_data call we are storing either 'tu' or 'tuaa'
- * which stands for one trie structure, one hash, optionally followed
- * by two arrays */
-#ifdef DEBUGGING
- const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tuaa"));
- AV *trie_words = NULL;
- /* along with revcharmap, this only used during construction but both are
- * useful during debugging so we store them in the struct when debugging.
- */
-#else
- const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tu"));
- STRLEN trie_charcount=0;
-#endif
- SV *re_trie_maxbuff;
- DECLARE_AND_GET_RE_DEBUG_FLAGS;
-
- PERL_ARGS_ASSERT_MAKE_TRIE;
-#ifndef DEBUGGING
- PERL_UNUSED_ARG(depth);
-#endif
-
- switch (flags) {
- case EXACT: case EXACT_REQ8: case EXACTL: break;
- case EXACTFAA:
- case EXACTFUP:
- case EXACTFU:
- case EXACTFLU8: folder = PL_fold_latin1; break;
- case EXACTF: folder = PL_fold; break;
- default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
- }
-
- trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
- trie->refcount = 1;
- trie->startstate = 1;
- trie->wordcount = word_count;
- RExC_rxi->data->data[ data_slot ] = (void*)trie;
- trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
- if (flags == EXACT || flags == EXACT_REQ8 || flags == EXACTL)
- trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
- trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
- trie->wordcount+1, sizeof(reg_trie_wordinfo));
-
- DEBUG_r({
- trie_words = newAV();
- });
-
- re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, GV_ADD);
- assert(re_trie_maxbuff);
- if (!SvIOK(re_trie_maxbuff)) {
- sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
- }
- DEBUG_TRIE_COMPILE_r({
- Perl_re_indentf( aTHX_
- "make_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
- depth+1,
- REG_NODE_NUM(startbranch), REG_NODE_NUM(first),
- REG_NODE_NUM(last), REG_NODE_NUM(tail), (int)depth);
- });
-
- /* Find the node we are going to overwrite */
- if ( first == startbranch && OP( last ) != BRANCH ) {
- /* whole branch chain */
- convert = first;
- } else {
- /* branch sub-chain */
- convert = NEXTOPER( first );
- }
-
- /* -- First loop and Setup --
-
- We first traverse the branches and scan each word to determine if it
- contains widechars, and how many unique chars there are, this is
- important as we have to build a table with at least as many columns as we
- have unique chars.
-
- We use an array of integers to represent the character codes 0..255
- (trie->charmap) and we use a an HV* to store Unicode characters. We use
- the native representation of the character value as the key and IV's for
- the coded index.
-
- *TODO* If we keep track of how many times each character is used we can
- remap the columns so that the table compression later on is more
- efficient in terms of memory by ensuring the most common value is in the
- middle and the least common are on the outside. IMO this would be better
- than a most to least common mapping as theres a decent chance the most
- common letter will share a node with the least common, meaning the node
- will not be compressible. With a middle is most common approach the worst
- case is when we have the least common nodes twice.
-
- */
-
- for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
- regnode *noper = NEXTOPER( cur );
- const U8 *uc;
- const U8 *e;
- int foldlen = 0;
- U32 wordlen = 0; /* required init */
- STRLEN minchars = 0;
- STRLEN maxchars = 0;
- bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the
- bitmap?*/
-
- if (OP(noper) == NOTHING) {
- /* skip past a NOTHING at the start of an alternation
- * eg, /(?:)a|(?:b)/ should be the same as /a|b/
- *
- * If the next node is not something we are supposed to process
- * we will just ignore it due to the condition guarding the
- * next block.
- */
-
- regnode *noper_next= regnext(noper);
- if (noper_next < tail)
- noper= noper_next;
- }
-
- if ( noper < tail
- && ( OP(noper) == flags
- || (flags == EXACT && OP(noper) == EXACT_REQ8)
- || (flags == EXACTFU && ( OP(noper) == EXACTFU_REQ8
- || OP(noper) == EXACTFUP))))
- {
- uc= (U8*)STRING(noper);
- e= uc + STR_LEN(noper);
- } else {
- trie->minlen= 0;
- continue;
- }
-
-
- if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
- TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
- regardless of encoding */
- if (OP( noper ) == EXACTFUP) {
- /* false positives are ok, so just set this */
- TRIE_BITMAP_SET(trie, LATIN_SMALL_LETTER_SHARP_S);
- }
- }
-
- for ( ; uc < e ; uc += len ) { /* Look at each char in the current
- branch */
- TRIE_CHARCOUNT(trie)++;
- TRIE_READ_CHAR;
-
- /* TRIE_READ_CHAR returns the current character, or its fold if /i
- * is in effect. Under /i, this character can match itself, or
- * anything that folds to it. If not under /i, it can match just
- * itself. Most folds are 1-1, for example k, K, and KELVIN SIGN
- * all fold to k, and all are single characters. But some folds
- * expand to more than one character, so for example LATIN SMALL
- * LIGATURE FFI folds to the three character sequence 'ffi'. If
- * the string beginning at 'uc' is 'ffi', it could be matched by
- * three characters, or just by the one ligature character. (It
- * could also be matched by two characters: LATIN SMALL LIGATURE FF
- * followed by 'i', or by 'f' followed by LATIN SMALL LIGATURE FI).
- * (Of course 'I' and/or 'F' instead of 'i' and 'f' can also
- * match.) The trie needs to know the minimum and maximum number
- * of characters that could match so that it can use size alone to
- * quickly reject many match attempts. The max is simple: it is
- * the number of folded characters in this branch (since a fold is
- * never shorter than what folds to it. */
-
- maxchars++;
-
- /* And the min is equal to the max if not under /i (indicated by
- * 'folder' being NULL), or there are no multi-character folds. If
- * there is a multi-character fold, the min is incremented just
- * once, for the character that folds to the sequence. Each
- * character in the sequence needs to be added to the list below of
- * characters in the trie, but we count only the first towards the
- * min number of characters needed. This is done through the
- * variable 'foldlen', which is returned by the macros that look
- * for these sequences as the number of bytes the sequence
- * occupies. Each time through the loop, we decrement 'foldlen' by
- * how many bytes the current char occupies. Only when it reaches
- * 0 do we increment 'minchars' or look for another multi-character
- * sequence. */
- if (folder == NULL) {
- minchars++;
- }
- else if (foldlen > 0) {
- foldlen -= (UTF) ? UTF8SKIP(uc) : 1;
- }
- else {
- minchars++;
-
- /* See if *uc is the beginning of a multi-character fold. If
- * so, we decrement the length remaining to look at, to account
- * for the current character this iteration. (We can use 'uc'
- * instead of the fold returned by TRIE_READ_CHAR because the
- * macro is smart enough to account for any unfolded
- * characters. */
- if (UTF) {
- if ((foldlen = is_MULTI_CHAR_FOLD_utf8_safe(uc, e))) {
- foldlen -= UTF8SKIP(uc);
- }
- }
- else if ((foldlen = is_MULTI_CHAR_FOLD_latin1_safe(uc, e))) {
- foldlen--;
- }
- }
-
- /* The current character (and any potential folds) should be added
- * to the possible matching characters for this position in this
- * branch */
- if ( uvc < 256 ) {
- if ( folder ) {
- U8 folded= folder[ (U8) uvc ];
- if ( !trie->charmap[ folded ] ) {
- trie->charmap[ folded ]=( ++trie->uniquecharcount );
- TRIE_STORE_REVCHAR( folded );
- }
- }
- if ( !trie->charmap[ uvc ] ) {
- trie->charmap[ uvc ]=( ++trie->uniquecharcount );
- TRIE_STORE_REVCHAR( uvc );
- }
- if ( set_bit ) {
- /* store the codepoint in the bitmap, and its folded
- * equivalent. */
- TRIE_BITMAP_SET_FOLDED(trie, uvc, folder);
- set_bit = 0; /* We've done our bit :-) */
- }
- } else {
-
- /* XXX We could come up with the list of code points that fold
- * to this using PL_utf8_foldclosures, except not for
- * multi-char folds, as there may be multiple combinations
- * there that could work, which needs to wait until runtime to
- * resolve (The comment about LIGATURE FFI above is such an
- * example */
-
- SV** svpp;
- if ( !widecharmap )
- widecharmap = newHV();
-
- svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
-
- if ( !svpp )
- Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%" UVXf, uvc );
-
- if ( !SvTRUE( *svpp ) ) {
- sv_setiv( *svpp, ++trie->uniquecharcount );
- TRIE_STORE_REVCHAR(uvc);
- }
- }
- } /* end loop through characters in this branch of the trie */
-
- /* We take the min and max for this branch and combine to find the min
- * and max for all branches processed so far */
- if( cur == first ) {
- trie->minlen = minchars;
- trie->maxlen = maxchars;
- } else if (minchars < trie->minlen) {
- trie->minlen = minchars;
- } else if (maxchars > trie->maxlen) {
- trie->maxlen = maxchars;
- }
- } /* end first pass */
- DEBUG_TRIE_COMPILE_r(
- Perl_re_indentf( aTHX_
- "TRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
- depth+1,
- ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
- (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
- (int)trie->minlen, (int)trie->maxlen )
- );
-
- /*
- We now know what we are dealing with in terms of unique chars and
- string sizes so we can calculate how much memory a naive
- representation using a flat table will take. If it's over a reasonable
- limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
- conservative but potentially much slower representation using an array
- of lists.
-
- At the end we convert both representations into the same compressed
- form that will be used in regexec.c for matching with. The latter
- is a form that cannot be used to construct with but has memory
- properties similar to the list form and access properties similar
- to the table form making it both suitable for fast searches and
- small enough that its feasable to store for the duration of a program.
-
- See the comment in the code where the compressed table is produced
- inplace from the flat tabe representation for an explanation of how
- the compression works.
-
- */
-
-
- Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
- prev_states[1] = 0;
-
- if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1)
- > SvIV(re_trie_maxbuff) )
- {
- /*
- Second Pass -- Array Of Lists Representation
-
- Each state will be represented by a list of charid:state records
- (reg_trie_trans_le) the first such element holds the CUR and LEN
- points of the allocated array. (See defines above).
-
- We build the initial structure using the lists, and then convert
- it into the compressed table form which allows faster lookups
- (but cant be modified once converted).
- */
-
- STRLEN transcount = 1;
-
- DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_ "Compiling trie using list compiler\n",
- depth+1));
-
- trie->states = (reg_trie_state *)
- PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
- sizeof(reg_trie_state) );
- TRIE_LIST_NEW(1);
- next_alloc = 2;
-
- for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
-
- regnode *noper = NEXTOPER( cur );
- U32 state = 1; /* required init */
- U16 charid = 0; /* sanity init */
- U32 wordlen = 0; /* required init */
-
- if (OP(noper) == NOTHING) {
- regnode *noper_next= regnext(noper);
- if (noper_next < tail)
- noper= noper_next;
- /* we will undo this assignment if noper does not
- * point at a trieable type in the else clause of
- * the following statement. */
- }
-
- if ( noper < tail
- && ( OP(noper) == flags
- || (flags == EXACT && OP(noper) == EXACT_REQ8)
- || (flags == EXACTFU && ( OP(noper) == EXACTFU_REQ8
- || OP(noper) == EXACTFUP))))
- {
- const U8 *uc= (U8*)STRING(noper);
- const U8 *e= uc + STR_LEN(noper);
-
- for ( ; uc < e ; uc += len ) {
-
- TRIE_READ_CHAR;
-
- if ( uvc < 256 ) {
- charid = trie->charmap[ uvc ];
- } else {
- SV** const svpp = hv_fetch( widecharmap,
- (char*)&uvc,
- sizeof( UV ),
- 0);
- if ( !svpp ) {
- charid = 0;
- } else {
- charid=(U16)SvIV( *svpp );
- }
- }
- /* charid is now 0 if we dont know the char read, or
- * nonzero if we do */
- if ( charid ) {
-
- U16 check;
- U32 newstate = 0;
-
- charid--;
- if ( !trie->states[ state ].trans.list ) {
- TRIE_LIST_NEW( state );
- }
- for ( check = 1;
- check <= TRIE_LIST_USED( state );
- check++ )
- {
- if ( TRIE_LIST_ITEM( state, check ).forid
- == charid )
- {
- newstate = TRIE_LIST_ITEM( state, check ).newstate;
- break;
- }
- }
- if ( ! newstate ) {
- newstate = next_alloc++;
- prev_states[newstate] = state;
- TRIE_LIST_PUSH( state, charid, newstate );
- transcount++;
- }
- state = newstate;
- } else {
- Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
- }
- }
- } else {
- /* If we end up here it is because we skipped past a NOTHING, but did not end up
- * on a trieable type. So we need to reset noper back to point at the first regop
- * in the branch before we call TRIE_HANDLE_WORD()
- */
- noper= NEXTOPER(cur);
- }
- TRIE_HANDLE_WORD(state);
-
- } /* end second pass */
-
- /* next alloc is the NEXT state to be allocated */
- trie->statecount = next_alloc;
- trie->states = (reg_trie_state *)
- PerlMemShared_realloc( trie->states,
- next_alloc
- * sizeof(reg_trie_state) );
-
- /* and now dump it out before we compress it */
- DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
- revcharmap, next_alloc,
- depth+1)
- );
-
- trie->trans = (reg_trie_trans *)
- PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
- {
- U32 state;
- U32 tp = 0;
- U32 zp = 0;
-
-
- for( state=1 ; state < next_alloc ; state ++ ) {
- U32 base=0;
-
- /*
- DEBUG_TRIE_COMPILE_MORE_r(
- Perl_re_printf( aTHX_ "tp: %d zp: %d ",tp,zp)
- );
- */
-
- if (trie->states[state].trans.list) {
- U16 minid=TRIE_LIST_ITEM( state, 1).forid;
- U16 maxid=minid;
- U16 idx;
-
- for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
- const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
- if ( forid < minid ) {
- minid=forid;
- } else if ( forid > maxid ) {
- maxid=forid;
- }
- }
- if ( transcount < tp + maxid - minid + 1) {
- transcount *= 2;
- trie->trans = (reg_trie_trans *)
- PerlMemShared_realloc( trie->trans,
- transcount
- * sizeof(reg_trie_trans) );
- Zero( trie->trans + (transcount / 2),
- transcount / 2,
- reg_trie_trans );
- }
- base = trie->uniquecharcount + tp - minid;
- if ( maxid == minid ) {
- U32 set = 0;
- for ( ; zp < tp ; zp++ ) {
- if ( ! trie->trans[ zp ].next ) {
- base = trie->uniquecharcount + zp - minid;
- trie->trans[ zp ].next = TRIE_LIST_ITEM( state,
- 1).newstate;
- trie->trans[ zp ].check = state;
- set = 1;
- break;
- }
- }
- if ( !set ) {
- trie->trans[ tp ].next = TRIE_LIST_ITEM( state,
- 1).newstate;
- trie->trans[ tp ].check = state;
- tp++;
- zp = tp;
- }
- } else {
- for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
- const U32 tid = base
- - trie->uniquecharcount
- + TRIE_LIST_ITEM( state, idx ).forid;
- trie->trans[ tid ].next = TRIE_LIST_ITEM( state,
- idx ).newstate;
- trie->trans[ tid ].check = state;
- }
- tp += ( maxid - minid + 1 );
- }
- Safefree(trie->states[ state ].trans.list);
- }
- /*
- DEBUG_TRIE_COMPILE_MORE_r(
- Perl_re_printf( aTHX_ " base: %d\n",base);
- );
- */
- trie->states[ state ].trans.base=base;
- }
- trie->lasttrans = tp + 1;
- }
- } else {
- /*
- Second Pass -- Flat Table Representation.
-
- we dont use the 0 slot of either trans[] or states[] so we add 1 to
- each. We know that we will need Charcount+1 trans at most to store
- the data (one row per char at worst case) So we preallocate both
- structures assuming worst case.
-
- We then construct the trie using only the .next slots of the entry
- structs.
-
- We use the .check field of the first entry of the node temporarily
- to make compression both faster and easier by keeping track of how
- many non zero fields are in the node.
-
- Since trans are numbered from 1 any 0 pointer in the table is a FAIL
- transition.
-
- There are two terms at use here: state as a TRIE_NODEIDX() which is
- a number representing the first entry of the node, and state as a
- TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1)
- and TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3)
- if there are 2 entrys per node. eg:
-
- A B A B
- 1. 2 4 1. 3 7
- 2. 0 3 3. 0 5
- 3. 0 0 5. 0 0
- 4. 0 0 7. 0 0
-
- The table is internally in the right hand, idx form. However as we
- also have to deal with the states array which is indexed by nodenum
- we have to use TRIE_NODENUM() to convert.
-
- */
- DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_ "Compiling trie using table compiler\n",
- depth+1));
-
- trie->trans = (reg_trie_trans *)
- PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
- * trie->uniquecharcount + 1,
- sizeof(reg_trie_trans) );
- trie->states = (reg_trie_state *)
- PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
- sizeof(reg_trie_state) );
- next_alloc = trie->uniquecharcount + 1;
-
-
- for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
-
- regnode *noper = NEXTOPER( cur );
-
- U32 state = 1; /* required init */
-
- U16 charid = 0; /* sanity init */
- U32 accept_state = 0; /* sanity init */
-
- U32 wordlen = 0; /* required init */
-
- if (OP(noper) == NOTHING) {
- regnode *noper_next= regnext(noper);
- if (noper_next < tail)
- noper= noper_next;
- /* we will undo this assignment if noper does not
- * point at a trieable type in the else clause of
- * the following statement. */
- }
-
- if ( noper < tail
- && ( OP(noper) == flags
- || (flags == EXACT && OP(noper) == EXACT_REQ8)
- || (flags == EXACTFU && ( OP(noper) == EXACTFU_REQ8
- || OP(noper) == EXACTFUP))))
- {
- const U8 *uc= (U8*)STRING(noper);
- const U8 *e= uc + STR_LEN(noper);
-
- for ( ; uc < e ; uc += len ) {
-
- TRIE_READ_CHAR;
-
- if ( uvc < 256 ) {
- charid = trie->charmap[ uvc ];
- } else {
- SV* const * const svpp = hv_fetch( widecharmap,
- (char*)&uvc,
- sizeof( UV ),
- 0);
- charid = svpp ? (U16)SvIV(*svpp) : 0;
- }
- if ( charid ) {
- charid--;
- if ( !trie->trans[ state + charid ].next ) {
- trie->trans[ state + charid ].next = next_alloc;
- trie->trans[ state ].check++;
- prev_states[TRIE_NODENUM(next_alloc)]
- = TRIE_NODENUM(state);
- next_alloc += trie->uniquecharcount;
- }
- state = trie->trans[ state + charid ].next;
- } else {
- Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
- }
- /* charid is now 0 if we dont know the char read, or
- * nonzero if we do */
- }
- } else {
- /* If we end up here it is because we skipped past a NOTHING, but did not end up
- * on a trieable type. So we need to reset noper back to point at the first regop
- * in the branch before we call TRIE_HANDLE_WORD().
- */
- noper= NEXTOPER(cur);
- }
- accept_state = TRIE_NODENUM( state );
- TRIE_HANDLE_WORD(accept_state);
-
- } /* end second pass */
-
- /* and now dump it out before we compress it */
- DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
- revcharmap,
- next_alloc, depth+1));
-
- {
- /*
- * Inplace compress the table.*
-
- For sparse data sets the table constructed by the trie algorithm will
- be mostly 0/FAIL transitions or to put it another way mostly empty.
- (Note that leaf nodes will not contain any transitions.)
-
- This algorithm compresses the tables by eliminating most such
- transitions, at the cost of a modest bit of extra work during lookup:
-
- - Each states[] entry contains a .base field which indicates the
- index in the state[] array wheres its transition data is stored.
-
- - If .base is 0 there are no valid transitions from that node.
-
- - If .base is nonzero then charid is added to it to find an entry in
- the trans array.
-
- -If trans[states[state].base+charid].check!=state then the
- transition is taken to be a 0/Fail transition. Thus if there are fail
- transitions at the front of the node then the .base offset will point
- somewhere inside the previous nodes data (or maybe even into a node
- even earlier), but the .check field determines if the transition is
- valid.
-
- XXX - wrong maybe?
- The following process inplace converts the table to the compressed
- table: We first do not compress the root node 1,and mark all its
- .check pointers as 1 and set its .base pointer as 1 as well. This
- allows us to do a DFA construction from the compressed table later,
- and ensures that any .base pointers we calculate later are greater
- than 0.
-
- - We set 'pos' to indicate the first entry of the second node.
-
- - We then iterate over the columns of the node, finding the first and
- last used entry at l and m. We then copy l..m into pos..(pos+m-l),
- and set the .check pointers accordingly, and advance pos
- appropriately and repreat for the next node. Note that when we copy
- the next pointers we have to convert them from the original
- NODEIDX form to NODENUM form as the former is not valid post
- compression.
-
- - If a node has no transitions used we mark its base as 0 and do not
- advance the pos pointer.
-
- - If a node only has one transition we use a second pointer into the
- structure to fill in allocated fail transitions from other states.
- This pointer is independent of the main pointer and scans forward
- looking for null transitions that are allocated to a state. When it
- finds one it writes the single transition into the "hole". If the
- pointer doesnt find one the single transition is appended as normal.
-
- - Once compressed we can Renew/realloc the structures to release the
- excess space.
-
- See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
- specifically Fig 3.47 and the associated pseudocode.
-
- demq
- */
- const U32 laststate = TRIE_NODENUM( next_alloc );
- U32 state, charid;
- U32 pos = 0, zp=0;
- trie->statecount = laststate;
-
- for ( state = 1 ; state < laststate ; state++ ) {
- U8 flag = 0;
- const U32 stateidx = TRIE_NODEIDX( state );
- const U32 o_used = trie->trans[ stateidx ].check;
- U32 used = trie->trans[ stateidx ].check;
- trie->trans[ stateidx ].check = 0;
-
- for ( charid = 0;
- used && charid < trie->uniquecharcount;
- charid++ )
- {
- if ( flag || trie->trans[ stateidx + charid ].next ) {
- if ( trie->trans[ stateidx + charid ].next ) {
- if (o_used == 1) {
- for ( ; zp < pos ; zp++ ) {
- if ( ! trie->trans[ zp ].next ) {
- break;
- }
- }
- trie->states[ state ].trans.base
- = zp
- + trie->uniquecharcount
- - charid ;
- trie->trans[ zp ].next
- = SAFE_TRIE_NODENUM( trie->trans[ stateidx
- + charid ].next );
- trie->trans[ zp ].check = state;
- if ( ++zp > pos ) pos = zp;
- break;
- }
- used--;
- }
- if ( !flag ) {
- flag = 1;
- trie->states[ state ].trans.base
- = pos + trie->uniquecharcount - charid ;
- }
- trie->trans[ pos ].next
- = SAFE_TRIE_NODENUM(
- trie->trans[ stateidx + charid ].next );
- trie->trans[ pos ].check = state;
- pos++;
- }
- }
- }
- trie->lasttrans = pos + 1;
- trie->states = (reg_trie_state *)
- PerlMemShared_realloc( trie->states, laststate
- * sizeof(reg_trie_state) );
- DEBUG_TRIE_COMPILE_MORE_r(
- Perl_re_indentf( aTHX_ "Alloc: %d Orig: %" IVdf " elements, Final:%" IVdf ". Savings of %%%5.2f\n",
- depth+1,
- (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount
- + 1 ),
- (IV)next_alloc,
- (IV)pos,
- ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
- );
-
- } /* end table compress */
- }
- DEBUG_TRIE_COMPILE_MORE_r(
- Perl_re_indentf( aTHX_ "Statecount:%" UVxf " Lasttrans:%" UVxf "\n",
- depth+1,
- (UV)trie->statecount,
- (UV)trie->lasttrans)
- );
- /* resize the trans array to remove unused space */
- trie->trans = (reg_trie_trans *)
- PerlMemShared_realloc( trie->trans, trie->lasttrans
- * sizeof(reg_trie_trans) );
-
- { /* Modify the program and insert the new TRIE node */
- U8 nodetype =(U8)(flags & 0xFF);
- char *str=NULL;
-
-#ifdef DEBUGGING
- regnode *optimize = NULL;
-#ifdef RE_TRACK_PATTERN_OFFSETS
-
- U32 mjd_offset = 0;
- U32 mjd_nodelen = 0;
-#endif /* RE_TRACK_PATTERN_OFFSETS */
-#endif /* DEBUGGING */
- /*
- This means we convert either the first branch or the first Exact,
- depending on whether the thing following (in 'last') is a branch
- or not and whther first is the startbranch (ie is it a sub part of
- the alternation or is it the whole thing.)
- Assuming its a sub part we convert the EXACT otherwise we convert
- the whole branch sequence, including the first.
- */
- /* Find the node we are going to overwrite */
- if ( first != startbranch || OP( last ) == BRANCH ) {
- /* branch sub-chain */
- NEXT_OFF( first ) = (U16)(last - first);
-#ifdef RE_TRACK_PATTERN_OFFSETS
- DEBUG_r({
- mjd_offset= Node_Offset((convert));
- mjd_nodelen= Node_Length((convert));
- });
-#endif
- /* whole branch chain */
- }
-#ifdef RE_TRACK_PATTERN_OFFSETS
- else {
- DEBUG_r({
- const regnode *nop = NEXTOPER( convert );
- mjd_offset= Node_Offset((nop));
- mjd_nodelen= Node_Length((nop));
- });
- }
- DEBUG_OPTIMISE_r(
- Perl_re_indentf( aTHX_ "MJD offset:%" UVuf " MJD length:%" UVuf "\n",
- depth+1,
- (UV)mjd_offset, (UV)mjd_nodelen)
- );
-#endif
- /* But first we check to see if there is a common prefix we can
- split out as an EXACT and put in front of the TRIE node. */
- trie->startstate= 1;
- if ( trie->bitmap && !widecharmap && !trie->jump ) {
- /* we want to find the first state that has more than
- * one transition, if that state is not the first state
- * then we have a common prefix which we can remove.
- */
- U32 state;
- for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
- U32 ofs = 0;
- I32 first_ofs = -1; /* keeps track of the ofs of the first
- transition, -1 means none */
- U32 count = 0;
- const U32 base = trie->states[ state ].trans.base;
-
- /* does this state terminate an alternation? */
- if ( trie->states[state].wordnum )
- count = 1;
-
- for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
- if ( ( base + ofs >= trie->uniquecharcount ) &&
- ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
- trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
- {
- if ( ++count > 1 ) {
- /* we have more than one transition */
- SV **tmp;
- U8 *ch;
- /* if this is the first state there is no common prefix
- * to extract, so we can exit */
- if ( state == 1 ) break;
- tmp = av_fetch( revcharmap, ofs, 0);
- ch = (U8*)SvPV_nolen_const( *tmp );
-
- /* if we are on count 2 then we need to initialize the
- * bitmap, and store the previous char if there was one
- * in it*/
- if ( count == 2 ) {
- /* clear the bitmap */
- Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
- DEBUG_OPTIMISE_r(
- Perl_re_indentf( aTHX_ "New Start State=%" UVuf " Class: [",
- depth+1,
- (UV)state));
- if (first_ofs >= 0) {
- SV ** const tmp = av_fetch( revcharmap, first_ofs, 0);
- const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
-
- TRIE_BITMAP_SET_FOLDED(trie,*ch, folder);
- DEBUG_OPTIMISE_r(
- Perl_re_printf( aTHX_ "%s", (char*)ch)
- );
- }
- }
- /* store the current firstchar in the bitmap */
- TRIE_BITMAP_SET_FOLDED(trie,*ch, folder);
- DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "%s", ch));
- }
- first_ofs = ofs;
- }
- }
- if ( count == 1 ) {
- /* This state has only one transition, its transition is part
- * of a common prefix - we need to concatenate the char it
- * represents to what we have so far. */
- SV **tmp = av_fetch( revcharmap, first_ofs, 0);
- STRLEN len;
- char *ch = SvPV( *tmp, len );
- DEBUG_OPTIMISE_r({
- SV *sv=sv_newmortal();
- Perl_re_indentf( aTHX_ "Prefix State: %" UVuf " Ofs:%" UVuf " Char='%s'\n",
- depth+1,
- (UV)state, (UV)first_ofs,
- pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
- PL_colors[0], PL_colors[1],
- (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
- PERL_PV_ESCAPE_FIRSTCHAR
- )
- );
- });
- if ( state==1 ) {
- OP( convert ) = nodetype;
- str=STRING(convert);
- setSTR_LEN(convert, 0);
- }
- assert( ( STR_LEN(convert) + len ) < 256 );
- setSTR_LEN(convert, (U8)(STR_LEN(convert) + len));
- while (len--)
- *str++ = *ch++;
- } else {
-#ifdef DEBUGGING
- if (state>1)
- DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "]\n"));
-#endif
- break;
- }
- }
- trie->prefixlen = (state-1);
- if (str) {
- regnode *n = convert+NODE_SZ_STR(convert);
- assert( NODE_SZ_STR(convert) <= U16_MAX );
- NEXT_OFF(convert) = (U16)(NODE_SZ_STR(convert));
- trie->startstate = state;
- trie->minlen -= (state - 1);
- trie->maxlen -= (state - 1);
-#ifdef DEBUGGING
- /* At least the UNICOS C compiler choked on this
- * being argument to DEBUG_r(), so let's just have
- * it right here. */
- if (
-#ifdef PERL_EXT_RE_BUILD
- 1
-#else
- DEBUG_r_TEST
-#endif
- ) {
- regnode *fix = convert;
- U32 word = trie->wordcount;
-#ifdef RE_TRACK_PATTERN_OFFSETS
- mjd_nodelen++;
-#endif
- Set_Node_Offset_Length(convert, mjd_offset, state - 1);
- while( ++fix < n ) {
- Set_Node_Offset_Length(fix, 0, 0);
- }
- while (word--) {
- SV ** const tmp = av_fetch( trie_words, word, 0 );
- if (tmp) {
- if ( STR_LEN(convert) <= SvCUR(*tmp) )
- sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
- else
- sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
- }
- }
- }
-#endif
- if (trie->maxlen) {
- convert = n;
- } else {
- NEXT_OFF(convert) = (U16)(tail - convert);
- DEBUG_r(optimize= n);
- }
- }
- }
- if (!jumper)
- jumper = last;
- if ( trie->maxlen ) {
- NEXT_OFF( convert ) = (U16)(tail - convert);
- ARG_SET( convert, data_slot );
- /* Store the offset to the first unabsorbed branch in
- jump[0], which is otherwise unused by the jump logic.
- We use this when dumping a trie and during optimisation. */
- if (trie->jump)
- trie->jump[0] = (U16)(nextbranch - convert);
-
- /* If the start state is not accepting (meaning there is no empty string/NOTHING)
- * and there is a bitmap
- * and the first "jump target" node we found leaves enough room
- * then convert the TRIE node into a TRIEC node, with the bitmap
- * embedded inline in the opcode - this is hypothetically faster.
- */
- if ( !trie->states[trie->startstate].wordnum
- && trie->bitmap
- && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
- {
- OP( convert ) = TRIEC;
- Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
- PerlMemShared_free(trie->bitmap);
- trie->bitmap= NULL;
- } else
- OP( convert ) = TRIE;
-
- /* store the type in the flags */
- convert->flags = nodetype;
- DEBUG_r({
- optimize = convert
- + NODE_STEP_REGNODE
- + regarglen[ OP( convert ) ];
- });
- /* XXX We really should free up the resource in trie now,
- as we won't use them - (which resources?) dmq */
- }
- /* needed for dumping*/
- DEBUG_r(if (optimize) {
- regnode *opt = convert;
-
- while ( ++opt < optimize) {
- Set_Node_Offset_Length(opt, 0, 0);
- }
- /*
- Try to clean up some of the debris left after the
- optimisation.
- */
- while( optimize < jumper ) {
- Track_Code( mjd_nodelen += Node_Length((optimize)); );
- OP( optimize ) = OPTIMIZED;
- Set_Node_Offset_Length(optimize, 0, 0);
- optimize++;
- }
- Set_Node_Offset_Length(convert, mjd_offset, mjd_nodelen);
- });
- } /* end node insert */
-
- /* Finish populating the prev field of the wordinfo array. Walk back
- * from each accept state until we find another accept state, and if
- * so, point the first word's .prev field at the second word. If the
- * second already has a .prev field set, stop now. This will be the
- * case either if we've already processed that word's accept state,
- * or that state had multiple words, and the overspill words were
- * already linked up earlier.
- */
- {
- U16 word;
- U32 state;
- U16 prev;
-
- for (word=1; word <= trie->wordcount; word++) {
- prev = 0;
- if (trie->wordinfo[word].prev)
- continue;
- state = trie->wordinfo[word].accept;
- while (state) {
- state = prev_states[state];
- if (!state)
- break;
- prev = trie->states[state].wordnum;
- if (prev)
- break;
- }
- trie->wordinfo[word].prev = prev;
- }
- Safefree(prev_states);
- }
-
-
- /* and now dump out the compressed format */
- DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
-
- RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
-#ifdef DEBUGGING
- RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
- RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
-#else
- SvREFCNT_dec_NN(revcharmap);
-#endif
- return trie->jump
- ? MADE_JUMP_TRIE
- : trie->startstate>1
- ? MADE_EXACT_TRIE
- : MADE_TRIE;
-}
-
-STATIC regnode *
-S_construct_ahocorasick_from_trie(pTHX_ RExC_state_t *pRExC_state, regnode *source, U32 depth)
-{
-/* The Trie is constructed and compressed now so we can build a fail array if
- * it's needed
-
- This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and
- 3.32 in the
- "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi,
- Ullman 1985/88
- ISBN 0-201-10088-6
-
- We find the fail state for each state in the trie, this state is the longest
- proper suffix of the current state's 'word' that is also a proper prefix of
- another word in our trie. State 1 represents the word '' and is thus the
- default fail state. This allows the DFA not to have to restart after its
- tried and failed a word at a given point, it simply continues as though it
- had been matching the other word in the first place.
- Consider
- 'abcdgu'=~/abcdefg|cdgu/
- When we get to 'd' we are still matching the first word, we would encounter
- 'g' which would fail, which would bring us to the state representing 'd' in
- the second word where we would try 'g' and succeed, proceeding to match
- 'cdgu'.
- */
- /* add a fail transition */
- const U32 trie_offset = ARG(source);
- reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
- U32 *q;
- const U32 ucharcount = trie->uniquecharcount;
- const U32 numstates = trie->statecount;
- const U32 ubound = trie->lasttrans + ucharcount;
- U32 q_read = 0;
- U32 q_write = 0;
- U32 charid;
- U32 base = trie->states[ 1 ].trans.base;
- U32 *fail;
- reg_ac_data *aho;
- const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("T"));
- regnode *stclass;
- DECLARE_AND_GET_RE_DEBUG_FLAGS;
-
- PERL_ARGS_ASSERT_CONSTRUCT_AHOCORASICK_FROM_TRIE;
- PERL_UNUSED_CONTEXT;
-#ifndef DEBUGGING
- PERL_UNUSED_ARG(depth);
-#endif
-
- if ( OP(source) == TRIE ) {
- struct regnode_1 *op = (struct regnode_1 *)
- PerlMemShared_calloc(1, sizeof(struct regnode_1));
- StructCopy(source, op, struct regnode_1);
- stclass = (regnode *)op;
- } else {
- struct regnode_charclass *op = (struct regnode_charclass *)
- PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
- StructCopy(source, op, struct regnode_charclass);
- stclass = (regnode *)op;
- }
- OP(stclass)+=2; /* convert the TRIE type to its AHO-CORASICK equivalent */
-
- ARG_SET( stclass, data_slot );
- aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
- RExC_rxi->data->data[ data_slot ] = (void*)aho;
- aho->trie=trie_offset;
- aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
- Copy( trie->states, aho->states, numstates, reg_trie_state );
- Newx( q, numstates, U32);
- aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
- aho->refcount = 1;
- fail = aho->fail;
- /* initialize fail[0..1] to be 1 so that we always have
- a valid final fail state */
- fail[ 0 ] = fail[ 1 ] = 1;
-
- for ( charid = 0; charid < ucharcount ; charid++ ) {
- const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
- if ( newstate ) {
- q[ q_write ] = newstate;
- /* set to point at the root */
- fail[ q[ q_write++ ] ]=1;
- }
- }
- while ( q_read < q_write) {
- const U32 cur = q[ q_read++ % numstates ];
- base = trie->states[ cur ].trans.base;
-
- for ( charid = 0 ; charid < ucharcount ; charid++ ) {
- const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
- if (ch_state) {
- U32 fail_state = cur;
- U32 fail_base;
- do {
- fail_state = fail[ fail_state ];
- fail_base = aho->states[ fail_state ].trans.base;
- } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
-
- fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
- fail[ ch_state ] = fail_state;
- if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
- {
- aho->states[ ch_state ].wordnum = aho->states[ fail_state ].wordnum;
- }
- q[ q_write++ % numstates] = ch_state;
- }
- }
- }
- /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
- when we fail in state 1, this allows us to use the
- charclass scan to find a valid start char. This is based on the principle
- that theres a good chance the string being searched contains lots of stuff
- that cant be a start char.
- */
- fail[ 0 ] = fail[ 1 ] = 0;
- DEBUG_TRIE_COMPILE_r({
- Perl_re_indentf( aTHX_ "Stclass Failtable (%" UVuf " states): 0",
- depth, (UV)numstates
- );
- for( q_read=1; q_read<numstates; q_read++ ) {
- Perl_re_printf( aTHX_ ", %" UVuf, (UV)fail[q_read]);
- }
- Perl_re_printf( aTHX_ "\n");
- });
- Safefree(q);
- /*RExC_seen |= REG_TRIEDFA_SEEN;*/
- return stclass;
-}
-
-
-/* The below joins as many adjacent EXACTish nodes as possible into a single
- * one. The regop may be changed if the node(s) contain certain sequences that
- * require special handling. The joining is only done if:
- * 1) there is room in the current conglomerated node to entirely contain the
- * next one.
- * 2) they are compatible node types
- *
- * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
- * these get optimized out
- *
- * XXX khw thinks this should be enhanced to fill EXACT (at least) nodes as full
- * as possible, even if that means splitting an existing node so that its first
- * part is moved to the preceeding node. This would maximise the efficiency of
- * memEQ during matching.
- *
- * If a node is to match under /i (folded), the number of characters it matches
- * can be different than its character length if it contains a multi-character
- * fold. *min_subtract is set to the total delta number of characters of the
- * input nodes.
- *
- * And *unfolded_multi_char is set to indicate whether or not the node contains
- * an unfolded multi-char fold. This happens when it won't be known until
- * runtime whether the fold is valid or not; namely
- * 1) for EXACTF nodes that contain LATIN SMALL LETTER SHARP S, as only if the
- * target string being matched against turns out to be UTF-8 is that fold
- * valid; or
- * 2) for EXACTFL nodes whose folding rules depend on the locale in force at
- * runtime.
- * (Multi-char folds whose components are all above the Latin1 range are not
- * run-time locale dependent, and have already been folded by the time this
- * function is called.)
- *
- * This is as good a place as any to discuss the design of handling these
- * multi-character fold sequences. It's been wrong in Perl for a very long
- * time. There are three code points in Unicode whose multi-character folds
- * were long ago discovered to mess things up. The previous designs for
- * dealing with these involved assigning a special node for them. This
- * approach doesn't always work, as evidenced by this example:
- * "\xDFs" =~ /s\xDF/ui # Used to fail before these patches
- * Both sides fold to "sss", but if the pattern is parsed to create a node that
- * would match just the \xDF, it won't be able to handle the case where a
- * successful match would have to cross the node's boundary. The new approach
- * that hopefully generally solves the problem generates an EXACTFUP node
- * that is "sss" in this case.
- *
- * It turns out that there are problems with all multi-character folds, and not
- * just these three. Now the code is general, for all such cases. The
- * approach taken is:
- * 1) This routine examines each EXACTFish node that could contain multi-
- * character folded sequences. Since a single character can fold into
- * such a sequence, the minimum match length for this node is less than
- * the number of characters in the node. This routine returns in
- * *min_subtract how many characters to subtract from the actual
- * length of the string to get a real minimum match length; it is 0 if
- * there are no multi-char foldeds. This delta is used by the caller to
- * adjust the min length of the match, and the delta between min and max,
- * so that the optimizer doesn't reject these possibilities based on size
- * constraints.
- *
- * 2) For the sequence involving the LATIN SMALL LETTER SHARP S (U+00DF)
- * under /u, we fold it to 'ss' in regatom(), and in this routine, after
- * joining, we scan for occurrences of the sequence 'ss' in non-UTF-8
- * EXACTFU nodes. The node type of such nodes is then changed to
- * EXACTFUP, indicating it is problematic, and needs careful handling.
- * (The procedures in step 1) above are sufficient to handle this case in
- * UTF-8 encoded nodes.) The reason this is problematic is that this is
- * the only case where there is a possible fold length change in non-UTF-8
- * patterns. By reserving a special node type for problematic cases, the
- * far more common regular EXACTFU nodes can be processed faster.
- * regexec.c takes advantage of this.
- *
- * EXACTFUP has been created as a grab-bag for (hopefully uncommon)
- * problematic cases. These all only occur when the pattern is not
- * UTF-8. In addition to the 'ss' sequence where there is a possible fold
- * length change, it handles the situation where the string cannot be
- * entirely folded. The strings in an EXACTFish node are folded as much
- * as possible during compilation in regcomp.c. This saves effort in
- * regex matching. By using an EXACTFUP node when it is not possible to
- * fully fold at compile time, regexec.c can know that everything in an
- * EXACTFU node is folded, so folding can be skipped at runtime. The only
- * case where folding in EXACTFU nodes can't be done at compile time is
- * the presumably uncommon MICRO SIGN, when the pattern isn't UTF-8. This
- * is because its fold requires UTF-8 to represent. Thus EXACTFUP nodes
- * handle two very different cases. Alternatively, there could have been
- * a node type where there are length changes, one for unfolded, and one
- * for both. If yet another special case needed to be created, the number
- * of required node types would have to go to 7. khw figures that even
- * though there are plenty of node types to spare, that the maintenance
- * cost wasn't worth the small speedup of doing it that way, especially
- * since he thinks the MICRO SIGN is rarely encountered in practice.
- *
- * There are other cases where folding isn't done at compile time, but
- * none of them are under /u, and hence not for EXACTFU nodes. The folds
- * in EXACTFL nodes aren't known until runtime, and vary as the locale
- * changes. Some folds in EXACTF depend on if the runtime target string
- * is UTF-8 or not. (regatom() will create an EXACTFU node even under /di
- * when no fold in it depends on the UTF-8ness of the target string.)
- *
- * 3) A problem remains for unfolded multi-char folds. (These occur when the
- * validity of the fold won't be known until runtime, and so must remain
- * unfolded for now. This happens for the sharp s in EXACTF and EXACTFAA
- * nodes when the pattern isn't in UTF-8. (Note, BTW, that there cannot
- * be an EXACTF node with a UTF-8 pattern.) They also occur for various
- * folds in EXACTFL nodes, regardless of the UTF-ness of the pattern.)
- * The reason this is a problem is that the optimizer part of regexec.c
- * (probably unwittingly, in Perl_regexec_flags()) makes an assumption
- * that a character in the pattern corresponds to at most a single
- * character in the target string. (And I do mean character, and not byte
- * here, unlike other parts of the documentation that have never been
- * updated to account for multibyte Unicode.) Sharp s in EXACTF and
- * EXACTFL nodes can match the two character string 'ss'; in EXACTFAA
- * nodes it can match "\x{17F}\x{17F}". These, along with other ones in
- * EXACTFL nodes, violate the assumption, and they are the only instances
- * where it is violated. I'm reluctant to try to change the assumption,
- * as the code involved is impenetrable to me (khw), so instead the code
- * here punts. This routine examines EXACTFL nodes, and (when the pattern
- * isn't UTF-8) EXACTF and EXACTFAA for such unfolded folds, and returns a
- * boolean indicating whether or not the node contains such a fold. When
- * it is true, the caller sets a flag that later causes the optimizer in
- * this file to not set values for the floating and fixed string lengths,
- * and thus avoids the optimizer code in regexec.c that makes the invalid
- * assumption. Thus, there is no optimization based on string lengths for
- * EXACTFL nodes that contain these few folds, nor for non-UTF8-pattern
- * EXACTF and EXACTFAA nodes that contain the sharp s. (The reason the
- * assumption is wrong only in these cases is that all other non-UTF-8
- * folds are 1-1; and, for UTF-8 patterns, we pre-fold all other folds to
- * their expanded versions. (Again, we can't prefold sharp s to 'ss' in
- * EXACTF nodes because we don't know at compile time if it actually
- * matches 'ss' or not. For EXACTF nodes it will match iff the target
- * string is in UTF-8. This is in contrast to EXACTFU nodes, where it
- * always matches; and EXACTFAA where it never does. In an EXACTFAA node
- * in a UTF-8 pattern, sharp s is folded to "\x{17F}\x{17F}, avoiding the
- * problem; but in a non-UTF8 pattern, folding it to that above-Latin1
- * string would require the pattern to be forced into UTF-8, the overhead
- * of which we want to avoid. Similarly the unfolded multi-char folds in
- * EXACTFL nodes will match iff the locale at the time of match is a UTF-8
- * locale.)
- *
- * Similarly, the code that generates tries doesn't currently handle
- * not-already-folded multi-char folds, and it looks like a pain to change
- * that. Therefore, trie generation of EXACTFAA nodes with the sharp s
- * doesn't work. Instead, such an EXACTFAA is turned into a new regnode,
- * EXACTFAA_NO_TRIE, which the trie code knows not to handle. Most people
- * using /iaa matching will be doing so almost entirely with ASCII
- * strings, so this should rarely be encountered in practice */
-
-STATIC U32
-S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan,
- UV *min_subtract, bool *unfolded_multi_char,
- U32 flags, regnode *val, U32 depth)
-{
- /* Merge several consecutive EXACTish nodes into one. */
-
- regnode *n = regnext(scan);
- U32 stringok = 1;
- regnode *next = scan + NODE_SZ_STR(scan);
- U32 merged = 0;
- U32 stopnow = 0;
-#ifdef DEBUGGING
- regnode *stop = scan;
- DECLARE_AND_GET_RE_DEBUG_FLAGS;
-#else
- PERL_UNUSED_ARG(depth);
-#endif
-
- PERL_ARGS_ASSERT_JOIN_EXACT;
-#ifndef EXPERIMENTAL_INPLACESCAN
- PERL_UNUSED_ARG(flags);
- PERL_UNUSED_ARG(val);
-#endif
- DEBUG_PEEP("join", scan, depth, 0);
-
- assert(PL_regkind[OP(scan)] == EXACT);
-
- /* Look through the subsequent nodes in the chain. Skip NOTHING, merge
- * EXACT ones that are mergeable to the current one. */
- while ( n
- && ( PL_regkind[OP(n)] == NOTHING
- || (stringok && PL_regkind[OP(n)] == EXACT))
- && NEXT_OFF(n)
- && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
- {
-
- if (OP(n) == TAIL || n > next)
- stringok = 0;
- if (PL_regkind[OP(n)] == NOTHING) {
- DEBUG_PEEP("skip:", n, depth, 0);
- NEXT_OFF(scan) += NEXT_OFF(n);
- next = n + NODE_STEP_REGNODE;
-#ifdef DEBUGGING
- if (stringok)
- stop = n;
-#endif
- n = regnext(n);
- }
- else if (stringok) {
- const unsigned int oldl = STR_LEN(scan);
- regnode * const nnext = regnext(n);
-
- /* XXX I (khw) kind of doubt that this works on platforms (should
- * Perl ever run on one) where U8_MAX is above 255 because of lots
- * of other assumptions */
- /* Don't join if the sum can't fit into a single node */
- if (oldl + STR_LEN(n) > U8_MAX)
- break;
-
- /* Joining something that requires UTF-8 with something that
- * doesn't, means the result requires UTF-8. */
- if (OP(scan) == EXACT && (OP(n) == EXACT_REQ8)) {
- OP(scan) = EXACT_REQ8;
- }
- else if (OP(scan) == EXACT_REQ8 && (OP(n) == EXACT)) {
- ; /* join is compatible, no need to change OP */
- }
- else if ((OP(scan) == EXACTFU) && (OP(n) == EXACTFU_REQ8)) {
- OP(scan) = EXACTFU_REQ8;
- }
- else if ((OP(scan) == EXACTFU_REQ8) && (OP(n) == EXACTFU)) {
- ; /* join is compatible, no need to change OP */
- }
- else if (OP(scan) == EXACTFU && OP(n) == EXACTFU) {
- ; /* join is compatible, no need to change OP */
- }
- else if (OP(scan) == EXACTFU && OP(n) == EXACTFU_S_EDGE) {
-
- /* Under /di, temporary EXACTFU_S_EDGE nodes are generated,
- * which can join with EXACTFU ones. We check for this case
- * here. These need to be resolved to either EXACTFU or
- * EXACTF at joining time. They have nothing in them that
- * would forbid them from being the more desirable EXACTFU
- * nodes except that they begin and/or end with a single [Ss].
- * The reason this is problematic is because they could be
- * joined in this loop with an adjacent node that ends and/or
- * begins with [Ss] which would then form the sequence 'ss',
- * which matches differently under /di than /ui, in which case
- * EXACTFU can't be used. If the 'ss' sequence doesn't get
- * formed, the nodes get absorbed into any adjacent EXACTFU
- * node. And if the only adjacent node is EXACTF, they get
- * absorbed into that, under the theory that a longer node is
- * better than two shorter ones, even if one is EXACTFU. Note
- * that EXACTFU_REQ8 is generated only for UTF-8 patterns,
- * and the EXACTFU_S_EDGE ones only for non-UTF-8. */
-
- if (STRING(n)[STR_LEN(n)-1] == 's') {
-
- /* Here the joined node would end with 's'. If the node
- * following the combination is an EXACTF one, it's better to
- * join this trailing edge 's' node with that one, leaving the
- * current one in 'scan' be the more desirable EXACTFU */
- if (OP(nnext) == EXACTF) {
- break;
- }
-
- OP(scan) = EXACTFU_S_EDGE;
-
- } /* Otherwise, the beginning 's' of the 2nd node just
- becomes an interior 's' in 'scan' */
- }
- else if (OP(scan) == EXACTF && OP(n) == EXACTF) {
- ; /* join is compatible, no need to change OP */
- }
- else if (OP(scan) == EXACTF && OP(n) == EXACTFU_S_EDGE) {
-
- /* EXACTF nodes are compatible for joining with EXACTFU_S_EDGE
- * nodes. But the latter nodes can be also joined with EXACTFU
- * ones, and that is a better outcome, so if the node following
- * 'n' is EXACTFU, quit now so that those two can be joined
- * later */
- if (OP(nnext) == EXACTFU) {
- break;
- }
-
- /* The join is compatible, and the combined node will be
- * EXACTF. (These don't care if they begin or end with 's' */
- }
- else if (OP(scan) == EXACTFU_S_EDGE && OP(n) == EXACTFU_S_EDGE) {
- if ( STRING(scan)[STR_LEN(scan)-1] == 's'
- && STRING(n)[0] == 's')
- {
- /* When combined, we have the sequence 'ss', which means we
- * have to remain /di */
- OP(scan) = EXACTF;
- }
- }
- else if (OP(scan) == EXACTFU_S_EDGE && OP(n) == EXACTFU) {
- if (STRING(n)[0] == 's') {
- ; /* Here the join is compatible and the combined node
- starts with 's', no need to change OP */
- }
- else { /* Now the trailing 's' is in the interior */
- OP(scan) = EXACTFU;
- }
- }
- else if (OP(scan) == EXACTFU_S_EDGE && OP(n) == EXACTF) {
-
- /* The join is compatible, and the combined node will be
- * EXACTF. (These don't care if they begin or end with 's' */
- OP(scan) = EXACTF;
- }
- else if (OP(scan) != OP(n)) {
-
- /* The only other compatible joinings are the same node type */
- break;
- }
-
- DEBUG_PEEP("merg", n, depth, 0);
- merged++;
-
- NEXT_OFF(scan) += NEXT_OFF(n);
- assert( ( STR_LEN(scan) + STR_LEN(n) ) < 256 );
- setSTR_LEN(scan, (U8)(STR_LEN(scan) + STR_LEN(n)));
- next = n + NODE_SZ_STR(n);
- /* Now we can overwrite *n : */
- Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
-#ifdef DEBUGGING
- stop = next - 1;
-#endif
- n = nnext;
- if (stopnow) break;
- }
-
-#ifdef EXPERIMENTAL_INPLACESCAN
- if (flags && !NEXT_OFF(n)) {
- DEBUG_PEEP("atch", val, depth, 0);
- if (reg_off_by_arg[OP(n)]) {
- ARG_SET(n, val - n);
- }
- else {
- NEXT_OFF(n) = val - n;
- }
- stopnow = 1;
- }
-#endif
- }
-
- /* This temporary node can now be turned into EXACTFU, and must, as
- * regexec.c doesn't handle it */
- if (OP(scan) == EXACTFU_S_EDGE) {
- OP(scan) = EXACTFU;
- }
-
- *min_subtract = 0;
- *unfolded_multi_char = FALSE;
-
- /* Here, all the adjacent mergeable EXACTish nodes have been merged. We
- * can now analyze for sequences of problematic code points. (Prior to
- * this final joining, sequences could have been split over boundaries, and
- * hence missed). The sequences only happen in folding, hence for any
- * non-EXACT EXACTish node */
- if (OP(scan) != EXACT && OP(scan) != EXACT_REQ8 && OP(scan) != EXACTL) {
- U8* s0 = (U8*) STRING(scan);
- U8* s = s0;
- U8* s_end = s0 + STR_LEN(scan);
-
- int total_count_delta = 0; /* Total delta number of characters that
- multi-char folds expand to */
-
- /* One pass is made over the node's string looking for all the
- * possibilities. To avoid some tests in the loop, there are two main
- * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
- * non-UTF-8 */
- if (UTF) {
- U8* folded = NULL;
-
- if (OP(scan) == EXACTFL) {
- U8 *d;
-
- /* An EXACTFL node would already have been changed to another
- * node type unless there is at least one character in it that
- * is problematic; likely a character whose fold definition
- * won't be known until runtime, and so has yet to be folded.
- * For all but the UTF-8 locale, folds are 1-1 in length, but
- * to handle the UTF-8 case, we need to create a temporary
- * folded copy using UTF-8 locale rules in order to analyze it.
- * This is because our macros that look to see if a sequence is
- * a multi-char fold assume everything is folded (otherwise the
- * tests in those macros would be too complicated and slow).
- * Note that here, the non-problematic folds will have already
- * been done, so we can just copy such characters. We actually
- * don't completely fold the EXACTFL string. We skip the
- * unfolded multi-char folds, as that would just create work
- * below to figure out the size they already are */
-
- Newx(folded, UTF8_MAX_FOLD_CHAR_EXPAND * STR_LEN(scan) + 1, U8);
- d = folded;
- while (s < s_end) {
- STRLEN s_len = UTF8SKIP(s);
- if (! is_PROBLEMATIC_LOCALE_FOLD_utf8(s)) {
- Copy(s, d, s_len, U8);
- d += s_len;
- }
- else if (is_FOLDS_TO_MULTI_utf8(s)) {
- *unfolded_multi_char = TRUE;
- Copy(s, d, s_len, U8);
- d += s_len;
- }
- else if (isASCII(*s)) {
- *(d++) = toFOLD(*s);
- }
- else {
- STRLEN len;
- _toFOLD_utf8_flags(s, s_end, d, &len, FOLD_FLAGS_FULL);
- d += len;
- }
- s += s_len;
- }
-
- /* Point the remainder of the routine to look at our temporary
- * folded copy */
- s = folded;
- s_end = d;
- } /* End of creating folded copy of EXACTFL string */
-
- /* Examine the string for a multi-character fold sequence. UTF-8
- * patterns have all characters pre-folded by the time this code is
- * executed */
- while (s < s_end - 1) /* Can stop 1 before the end, as minimum
- length sequence we are looking for is 2 */
- {
- int count = 0; /* How many characters in a multi-char fold */
- int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
- if (! len) { /* Not a multi-char fold: get next char */
- s += UTF8SKIP(s);
- continue;
- }
-
- { /* Here is a generic multi-char fold. */
- U8* multi_end = s + len;
-
- /* Count how many characters are in it. In the case of
- * /aa, no folds which contain ASCII code points are
- * allowed, so check for those, and skip if found. */
- if (OP(scan) != EXACTFAA && OP(scan) != EXACTFAA_NO_TRIE) {
- count = utf8_length(s, multi_end);
- s = multi_end;
- }
- else {
- while (s < multi_end) {
- if (isASCII(*s)) {
- s++;
- goto next_iteration;
- }
- else {
- s += UTF8SKIP(s);
- }
- count++;
- }
- }
- }
-
- /* The delta is how long the sequence is minus 1 (1 is how long
- * the character that folds to the sequence is) */
- total_count_delta += count - 1;
- next_iteration: ;
- }
-
- /* We created a temporary folded copy of the string in EXACTFL
- * nodes. Therefore we need to be sure it doesn't go below zero,
- * as the real string could be shorter */
- if (OP(scan) == EXACTFL) {
- int total_chars = utf8_length((U8*) STRING(scan),
- (U8*) STRING(scan) + STR_LEN(scan));
- if (total_count_delta > total_chars) {
- total_count_delta = total_chars;
- }
- }
-
- *min_subtract += total_count_delta;
- Safefree(folded);
- }
- else if (OP(scan) == EXACTFAA) {
-
- /* Non-UTF-8 pattern, EXACTFAA node. There can't be a multi-char
- * fold to the ASCII range (and there are no existing ones in the
- * upper latin1 range). But, as outlined in the comments preceding
- * this function, we need to flag any occurrences of the sharp s.
- * This character forbids trie formation (because of added
- * complexity) */
-#if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \
- || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \
- || UNICODE_DOT_DOT_VERSION > 0)
- while (s < s_end) {
- if (*s == LATIN_SMALL_LETTER_SHARP_S) {
- OP(scan) = EXACTFAA_NO_TRIE;
- *unfolded_multi_char = TRUE;
- break;
- }
- s++;
- }
- }
- else if (OP(scan) != EXACTFAA_NO_TRIE) {
-
- /* Non-UTF-8 pattern, not EXACTFAA node. Look for the multi-char
- * folds that are all Latin1. As explained in the comments
- * preceding this function, we look also for the sharp s in EXACTF
- * and EXACTFL nodes; it can be in the final position. Otherwise
- * we can stop looking 1 byte earlier because have to find at least
- * two characters for a multi-fold */
- const U8* upper = (OP(scan) == EXACTF || OP(scan) == EXACTFL)
- ? s_end
- : s_end -1;
-
- while (s < upper) {
- int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
- if (! len) { /* Not a multi-char fold. */
- if (*s == LATIN_SMALL_LETTER_SHARP_S
- && (OP(scan) == EXACTF || OP(scan) == EXACTFL))
- {
- *unfolded_multi_char = TRUE;
- }
- s++;
- continue;
- }
-
- if (len == 2
- && isALPHA_FOLD_EQ(*s, 's')
- && isALPHA_FOLD_EQ(*(s+1), 's'))
- {
-
- /* EXACTF nodes need to know that the minimum length
- * changed so that a sharp s in the string can match this
- * ss in the pattern, but they remain EXACTF nodes, as they
- * won't match this unless the target string is in UTF-8,
- * which we don't know until runtime. EXACTFL nodes can't
- * transform into EXACTFU nodes */
- if (OP(scan) != EXACTF && OP(scan) != EXACTFL) {
- OP(scan) = EXACTFUP;
- }
- }
-
- *min_subtract += len - 1;
- s += len;
- }
-#endif
- }
- }
-
-#ifdef DEBUGGING
- /* Allow dumping but overwriting the collection of skipped
- * ops and/or strings with fake optimized ops */
- n = scan + NODE_SZ_STR(scan);
- while (n <= stop) {
- OP(n) = OPTIMIZED;
- FLAGS(n) = 0;
- NEXT_OFF(n) = 0;
- n++;
- }
-#endif
- DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl", scan, depth, 0);});
- return stopnow;
-}
-
-/* REx optimizer. Converts nodes into quicker variants "in place".
- Finds fixed substrings. */
-
-/* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
- to the position after last scanned or to NULL. */
-
-#define INIT_AND_WITHP \
- assert(!and_withp); \
- Newx(and_withp, 1, regnode_ssc); \
- SAVEFREEPV(and_withp)
-
-
-static void
-S_unwind_scan_frames(pTHX_ const void *p)
-{
- scan_frame *f= (scan_frame *)p;
- do {
- scan_frame *n= f->next_frame;
- Safefree(f);
- f= n;
- } while (f);
-}
-
-/* Follow the next-chain of the current node and optimize away
- all the NOTHINGs from it.
- */
-STATIC void
-S_rck_elide_nothing(pTHX_ regnode *node)
-{
- PERL_ARGS_ASSERT_RCK_ELIDE_NOTHING;
-
- if (OP(node) != CURLYX) {
- const int max = (reg_off_by_arg[OP(node)]
- ? I32_MAX
- /* I32 may be smaller than U16 on CRAYs! */
- : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
- int off = (reg_off_by_arg[OP(node)] ? ARG(node) : NEXT_OFF(node));
- int noff;
- regnode *n = node;
-
- /* Skip NOTHING and LONGJMP. */
- while (
- (n = regnext(n))
- && (
- (PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
- || ((OP(n) == LONGJMP) && (noff = ARG(n)))
- )
- && off + noff < max
- ) {
- off += noff;
- }
- if (reg_off_by_arg[OP(node)])
- ARG(node) = off;
- else
- NEXT_OFF(node) = off;
- }
- return;
-}
-
-/* the return from this sub is the minimum length that could possibly match */
-STATIC SSize_t
-S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
- SSize_t *minlenp, SSize_t *deltap,
- regnode *last,
- scan_data_t *data,
- I32 stopparen,
- U32 recursed_depth,
- regnode_ssc *and_withp,
- U32 flags, U32 depth, bool was_mutate_ok)
- /* scanp: Start here (read-write). */
- /* deltap: Write maxlen-minlen here. */
- /* last: Stop before this one. */
- /* data: string data about the pattern */
- /* stopparen: treat close N as END */
- /* recursed: which subroutines have we recursed into */
- /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
-{
- SSize_t final_minlen;
- /* There must be at least this number of characters to match */
- SSize_t min = 0;
- I32 pars = 0, code;
- regnode *scan = *scanp, *next;
- SSize_t delta = 0;
- int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
- int is_inf_internal = 0; /* The studied chunk is infinite */
- I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
- scan_data_t data_fake;
- SV *re_trie_maxbuff = NULL;
- regnode *first_non_open = scan;
- SSize_t stopmin = OPTIMIZE_INFTY;
- scan_frame *frame = NULL;
- DECLARE_AND_GET_RE_DEBUG_FLAGS;
-
- PERL_ARGS_ASSERT_STUDY_CHUNK;
- RExC_study_started= 1;
-
- Zero(&data_fake, 1, scan_data_t);
-
- if ( depth == 0 ) {
- while (first_non_open && OP(first_non_open) == OPEN)
- first_non_open=regnext(first_non_open);
- }
-
-
- fake_study_recurse:
- DEBUG_r(
- RExC_study_chunk_recursed_count++;
- );
- DEBUG_OPTIMISE_MORE_r(
- {
- Perl_re_indentf( aTHX_ "study_chunk stopparen=%ld recursed_count=%lu depth=%lu recursed_depth=%lu scan=%p last=%p",
- depth, (long)stopparen,
- (unsigned long)RExC_study_chunk_recursed_count,
- (unsigned long)depth, (unsigned long)recursed_depth,
- scan,
- last);
- if (recursed_depth) {
- U32 i;
- U32 j;
- for ( j = 0 ; j < recursed_depth ; j++ ) {
- for ( i = 0 ; i < (U32)RExC_total_parens ; i++ ) {
- if (PAREN_TEST(j, i) && (!j || !PAREN_TEST(j - 1, i))) {
- Perl_re_printf( aTHX_ " %d",(int)i);
- break;
- }
- }
- if ( j + 1 < recursed_depth ) {
- Perl_re_printf( aTHX_ ",");
- }
- }
- }
- Perl_re_printf( aTHX_ "\n");
- }
- );
- while ( scan && OP(scan) != END && scan < last ){
- UV min_subtract = 0; /* How mmany chars to subtract from the minimum
- node length to get a real minimum (because
- the folded version may be shorter) */
- bool unfolded_multi_char = FALSE;
- /* avoid mutating ops if we are anywhere within the recursed or
- * enframed handling for a GOSUB: the outermost level will handle it.
- */
- bool mutate_ok = was_mutate_ok && !(frame && frame->in_gosub);
- /* Peephole optimizer: */
- DEBUG_STUDYDATA("Peep", data, depth, is_inf);
- DEBUG_PEEP("Peep", scan, depth, flags);
-
-
- /* The reason we do this here is that we need to deal with things like
- * /(?:f)(?:o)(?:o)/ which cant be dealt with by the normal EXACT
- * parsing code, as each (?:..) is handled by a different invocation of
- * reg() -- Yves
- */
- if (PL_regkind[OP(scan)] == EXACT
- && OP(scan) != LEXACT
- && OP(scan) != LEXACT_REQ8
- && mutate_ok
- ) {
- join_exact(pRExC_state, scan, &min_subtract, &unfolded_multi_char,
- 0, NULL, depth + 1);
- }
-
- /* Follow the next-chain of the current node and optimize
- away all the NOTHINGs from it.
- */
- rck_elide_nothing(scan);
-
- /* The principal pseudo-switch. Cannot be a switch, since we look into
- * several different things. */
- if ( OP(scan) == DEFINEP ) {
- SSize_t minlen = 0;
- SSize_t deltanext = 0;
- SSize_t fake_last_close = 0;
- I32 f = SCF_IN_DEFINE;
-
- StructCopy(&zero_scan_data, &data_fake, scan_data_t);
- scan = regnext(scan);
- assert( OP(scan) == IFTHEN );
- DEBUG_PEEP("expect IFTHEN", scan, depth, flags);
-
- data_fake.last_closep= &fake_last_close;
- minlen = *minlenp;
- next = regnext(scan);
- scan = NEXTOPER(NEXTOPER(scan));
- DEBUG_PEEP("scan", scan, depth, flags);
- DEBUG_PEEP("next", next, depth, flags);
-
- /* we suppose the run is continuous, last=next...
- * NOTE we dont use the return here! */
- /* DEFINEP study_chunk() recursion */
- (void)study_chunk(pRExC_state, &scan, &minlen,
- &deltanext, next, &data_fake, stopparen,
- recursed_depth, NULL, f, depth+1, mutate_ok);
-
- scan = next;
- } else
- if (
- OP(scan) == BRANCH ||
- OP(scan) == BRANCHJ ||
- OP(scan) == IFTHEN
- ) {
- next = regnext(scan);
- code = OP(scan);
-
- /* The op(next)==code check below is to see if we
- * have "BRANCH-BRANCH", "BRANCHJ-BRANCHJ", "IFTHEN-IFTHEN"
- * IFTHEN is special as it might not appear in pairs.
- * Not sure whether BRANCH-BRANCHJ is possible, regardless
- * we dont handle it cleanly. */
- if (OP(next) == code || code == IFTHEN) {
- /* NOTE - There is similar code to this block below for
- * handling TRIE nodes on a re-study. If you change stuff here
- * check there too. */
- SSize_t max1 = 0, min1 = OPTIMIZE_INFTY, num = 0;
- regnode_ssc accum;
- regnode * const startbranch=scan;
-
- if (flags & SCF_DO_SUBSTR) {
- /* Cannot merge strings after this. */
- scan_commit(pRExC_state, data, minlenp, is_inf);
- }
-
- if (flags & SCF_DO_STCLASS)
- ssc_init_zero(pRExC_state, &accum);
-
- while (OP(scan) == code) {
- SSize_t deltanext, minnext, fake;
- I32 f = 0;
- regnode_ssc this_class;
-
- DEBUG_PEEP("Branch", scan, depth, flags);
-
- num++;
- StructCopy(&zero_scan_data, &data_fake, scan_data_t);
- if (data) {
- data_fake.whilem_c = data->whilem_c;
- data_fake.last_closep = data->last_closep;
- }
- else
- data_fake.last_closep = &fake;
-
- data_fake.pos_delta = delta;
- next = regnext(scan);
-
- scan = NEXTOPER(scan); /* everything */
- if (code != BRANCH) /* everything but BRANCH */
- scan = NEXTOPER(scan);
-
- if (flags & SCF_DO_STCLASS) {
- ssc_init(pRExC_state, &this_class);
- data_fake.start_class = &this_class;
- f = SCF_DO_STCLASS_AND;
- }
- if (flags & SCF_WHILEM_VISITED_POS)
- f |= SCF_WHILEM_VISITED_POS;
-
- /* we suppose the run is continuous, last=next...*/
- /* recurse study_chunk() for each BRANCH in an alternation */
- minnext = study_chunk(pRExC_state, &scan, minlenp,
- &deltanext, next, &data_fake, stopparen,
- recursed_depth, NULL, f, depth+1,
- mutate_ok);
-
- if (min1 > minnext)
- min1 = minnext;
- if (deltanext == OPTIMIZE_INFTY) {
- is_inf = is_inf_internal = 1;
- max1 = OPTIMIZE_INFTY;
- } else if (max1 < minnext + deltanext)
- max1 = minnext + deltanext;
- scan = next;
- if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
- pars++;
- if (data_fake.flags & SCF_SEEN_ACCEPT) {
- if ( stopmin > minnext)
- stopmin = min + min1;
- flags &= ~SCF_DO_SUBSTR;
- if (data)
- data->flags |= SCF_SEEN_ACCEPT;
- }
- if (data) {
- if (data_fake.flags & SF_HAS_EVAL)
- data->flags |= SF_HAS_EVAL;
- data->whilem_c = data_fake.whilem_c;
- }
- if (flags & SCF_DO_STCLASS)
- ssc_or(pRExC_state, &accum, (regnode_charclass*)&this_class);
- }
- if (code == IFTHEN && num < 2) /* Empty ELSE branch */
- min1 = 0;
- if (flags & SCF_DO_SUBSTR) {
- data->pos_min += min1;
- if (data->pos_delta >= OPTIMIZE_INFTY - (max1 - min1))
- data->pos_delta = OPTIMIZE_INFTY;
- else
- data->pos_delta += max1 - min1;
- if (max1 != min1 || is_inf)
- data->cur_is_floating = 1;
- }
- min += min1;
- if (delta == OPTIMIZE_INFTY
- || OPTIMIZE_INFTY - delta - (max1 - min1) < 0)
- delta = OPTIMIZE_INFTY;
- else
- delta += max1 - min1;
- if (flags & SCF_DO_STCLASS_OR) {
- ssc_or(pRExC_state, data->start_class, (regnode_charclass*) &accum);
- if (min1) {
- ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
- flags &= ~SCF_DO_STCLASS;
- }
- }
- else if (flags & SCF_DO_STCLASS_AND) {
- if (min1) {
- ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
- flags &= ~SCF_DO_STCLASS;
- }
- else {
- /* Switch to OR mode: cache the old value of
- * data->start_class */
- INIT_AND_WITHP;
- StructCopy(data->start_class, and_withp, regnode_ssc);
- flags &= ~SCF_DO_STCLASS_AND;
- StructCopy(&accum, data->start_class, regnode_ssc);
- flags |= SCF_DO_STCLASS_OR;
- }
- }
-
- if (PERL_ENABLE_TRIE_OPTIMISATION
- && OP(startbranch) == BRANCH
- && mutate_ok
- ) {
- /* demq.
-
- Assuming this was/is a branch we are dealing with: 'scan'
- now points at the item that follows the branch sequence,
- whatever it is. We now start at the beginning of the
- sequence and look for subsequences of
-
- BRANCH->EXACT=>x1
- BRANCH->EXACT=>x2
- tail
-
- which would be constructed from a pattern like
- /A|LIST|OF|WORDS/
-
- If we can find such a subsequence we need to turn the first
- element into a trie and then add the subsequent branch exact
- strings to the trie.
-
- We have two cases
-
- 1. patterns where the whole set of branches can be
- converted.
-
- 2. patterns where only a subset can be converted.
-
- In case 1 we can replace the whole set with a single regop
- for the trie. In case 2 we need to keep the start and end
- branches so
-
- 'BRANCH EXACT; BRANCH EXACT; BRANCH X'
- becomes BRANCH TRIE; BRANCH X;
-
- There is an additional case, that being where there is a
- common prefix, which gets split out into an EXACT like node
- preceding the TRIE node.
-
- If x(1..n)==tail then we can do a simple trie, if not we make
- a "jump" trie, such that when we match the appropriate word
- we "jump" to the appropriate tail node. Essentially we turn
- a nested if into a case structure of sorts.
-
- */
-
- int made=0;
- if (!re_trie_maxbuff) {
- re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
- if (!SvIOK(re_trie_maxbuff))
- sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
- }
- if ( SvIV(re_trie_maxbuff)>=0 ) {
- regnode *cur;
- regnode *first = (regnode *)NULL;
- regnode *prev = (regnode *)NULL;
- regnode *tail = scan;
- U8 trietype = 0;
- U32 count=0;
-
- /* var tail is used because there may be a TAIL
- regop in the way. Ie, the exacts will point to the
- thing following the TAIL, but the last branch will
- point at the TAIL. So we advance tail. If we
- have nested (?:) we may have to move through several
- tails.
- */
-
- while ( OP( tail ) == TAIL ) {
- /* this is the TAIL generated by (?:) */
- tail = regnext( tail );
- }
-
-
- DEBUG_TRIE_COMPILE_r({
- regprop(RExC_rx, RExC_mysv, tail, NULL, pRExC_state);
- Perl_re_indentf( aTHX_ "%s %" UVuf ":%s\n",
- depth+1,
- "Looking for TRIE'able sequences. Tail node is ",
- (UV) REGNODE_OFFSET(tail),
- SvPV_nolen_const( RExC_mysv )
- );
- });
-
- /*
-
- Step through the branches
- cur represents each branch,
- noper is the first thing to be matched as part
- of that branch
- noper_next is the regnext() of that node.
-
- We normally handle a case like this
- /FOO[xyz]|BAR[pqr]/ via a "jump trie" but we also
- support building with NOJUMPTRIE, which restricts
- the trie logic to structures like /FOO|BAR/.
-
- If noper is a trieable nodetype then the branch is
- a possible optimization target. If we are building
- under NOJUMPTRIE then we require that noper_next is
- the same as scan (our current position in the regex
- program).
-
- Once we have two or more consecutive such branches
- we can create a trie of the EXACT's contents and
- stitch it in place into the program.
-
- If the sequence represents all of the branches in
- the alternation we replace the entire thing with a
- single TRIE node.
-
- Otherwise when it is a subsequence we need to
- stitch it in place and replace only the relevant
- branches. This means the first branch has to remain
- as it is used by the alternation logic, and its
- next pointer, and needs to be repointed at the item
- on the branch chain following the last branch we
- have optimized away.
-
- This could be either a BRANCH, in which case the
- subsequence is internal, or it could be the item
- following the branch sequence in which case the
- subsequence is at the end (which does not
- necessarily mean the first node is the start of the
- alternation).
-
- TRIE_TYPE(X) is a define which maps the optype to a
- trietype.
-
- optype | trietype
- ----------------+-----------
- NOTHING | NOTHING
- EXACT | EXACT
- EXACT_REQ8 | EXACT
- EXACTFU | EXACTFU
- EXACTFU_REQ8 | EXACTFU
- EXACTFUP | EXACTFU
- EXACTFAA | EXACTFAA
- EXACTL | EXACTL
- EXACTFLU8 | EXACTFLU8
-
-
- */
-#define TRIE_TYPE(X) ( ( NOTHING == (X) ) \
- ? NOTHING \
- : ( EXACT == (X) || EXACT_REQ8 == (X) ) \
- ? EXACT \
- : ( EXACTFU == (X) \
- || EXACTFU_REQ8 == (X) \
- || EXACTFUP == (X) ) \
- ? EXACTFU \
- : ( EXACTFAA == (X) ) \
- ? EXACTFAA \
- : ( EXACTL == (X) ) \
- ? EXACTL \
- : ( EXACTFLU8 == (X) ) \
- ? EXACTFLU8 \
- : 0 )
-
- /* dont use tail as the end marker for this traverse */
- for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
- regnode * const noper = NEXTOPER( cur );
- U8 noper_type = OP( noper );
- U8 noper_trietype = TRIE_TYPE( noper_type );
-#if defined(DEBUGGING) || defined(NOJUMPTRIE)
- regnode * const noper_next = regnext( noper );
- U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
- U8 noper_next_trietype = (noper_next && noper_next < tail) ? TRIE_TYPE( noper_next_type ) :0;
-#endif
-
- DEBUG_TRIE_COMPILE_r({
- regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
- Perl_re_indentf( aTHX_ "- %d:%s (%d)",
- depth+1,
- REG_NODE_NUM(cur), SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur) );
-
- regprop(RExC_rx, RExC_mysv, noper, NULL, pRExC_state);
- Perl_re_printf( aTHX_ " -> %d:%s",
- REG_NODE_NUM(noper), SvPV_nolen_const(RExC_mysv));
-
- if ( noper_next ) {
- regprop(RExC_rx, RExC_mysv, noper_next, NULL, pRExC_state);
- Perl_re_printf( aTHX_ "\t=> %d:%s\t",
- REG_NODE_NUM(noper_next), SvPV_nolen_const(RExC_mysv));
- }
- Perl_re_printf( aTHX_ "(First==%d,Last==%d,Cur==%d,tt==%s,ntt==%s,nntt==%s)\n",
- REG_NODE_NUM(first), REG_NODE_NUM(prev), REG_NODE_NUM(cur),
- PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype]
- );
- });
-
- /* Is noper a trieable nodetype that can be merged
- * with the current trie (if there is one)? */
- if ( noper_trietype
- &&
- (
- ( noper_trietype == NOTHING )
- || ( trietype == NOTHING )
- || ( trietype == noper_trietype )
- )
-#ifdef NOJUMPTRIE
- && noper_next >= tail
-#endif
- && count < U16_MAX)
- {
- /* Handle mergable triable node Either we are
- * the first node in a new trieable sequence,
- * in which case we do some bookkeeping,
- * otherwise we update the end pointer. */
- if ( !first ) {
- first = cur;
- if ( noper_trietype == NOTHING ) {
-#if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
- regnode * const noper_next = regnext( noper );
- U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
- U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
-#endif
-
- if ( noper_next_trietype ) {
- trietype = noper_next_trietype;
- } else if (noper_next_type) {
- /* a NOTHING regop is 1 regop wide.
- * We need at least two for a trie
- * so we can't merge this in */
- first = NULL;
- }
- } else {
- trietype = noper_trietype;
- }
- } else {
- if ( trietype == NOTHING )
- trietype = noper_trietype;
- prev = cur;
- }
- if (first)
- count++;
- } /* end handle mergable triable node */
- else {
- /* handle unmergable node -
- * noper may either be a triable node which can
- * not be tried together with the current trie,
- * or a non triable node */
- if ( prev ) {
- /* If last is set and trietype is not
- * NOTHING then we have found at least two
- * triable branch sequences in a row of a
- * similar trietype so we can turn them
- * into a trie. If/when we allow NOTHING to
- * start a trie sequence this condition
- * will be required, and it isn't expensive
- * so we leave it in for now. */
- if ( trietype && trietype != NOTHING )
- make_trie( pRExC_state,
- startbranch, first, cur, tail,
- count, trietype, depth+1 );
- prev = NULL; /* note: we clear/update
- first, trietype etc below,
- so we dont do it here */
- }
- if ( noper_trietype
-#ifdef NOJUMPTRIE
- && noper_next >= tail
-#endif
- ){
- /* noper is triable, so we can start a new
- * trie sequence */
- count = 1;
- first = cur;
- trietype = noper_trietype;
- } else if (first) {
- /* if we already saw a first but the
- * current node is not triable then we have
- * to reset the first information. */
- count = 0;
- first = NULL;
- trietype = 0;
- }
- } /* end handle unmergable node */
- } /* loop over branches */
- DEBUG_TRIE_COMPILE_r({
- regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
- Perl_re_indentf( aTHX_ "- %s (%d) <SCAN FINISHED> ",
- depth+1, SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur));
- Perl_re_printf( aTHX_ "(First==%d, Last==%d, Cur==%d, tt==%s)\n",
- REG_NODE_NUM(first), REG_NODE_NUM(prev), REG_NODE_NUM(cur),
- PL_reg_name[trietype]
- );
-
- });
- if ( prev && trietype ) {
- if ( trietype != NOTHING ) {
- /* the last branch of the sequence was part of
- * a trie, so we have to construct it here
- * outside of the loop */
- made= make_trie( pRExC_state, startbranch,
- first, scan, tail, count,
- trietype, depth+1 );
-#ifdef TRIE_STUDY_OPT
- if ( ((made == MADE_EXACT_TRIE &&
- startbranch == first)
- || ( first_non_open == first )) &&
- depth==0 ) {
- flags |= SCF_TRIE_RESTUDY;
- if ( startbranch == first
- && scan >= tail )
- {
- RExC_seen &=~REG_TOP_LEVEL_BRANCHES_SEEN;
- }
- }
-#endif
- } else {
- /* at this point we know whatever we have is a
- * NOTHING sequence/branch AND if 'startbranch'
- * is 'first' then we can turn the whole thing
- * into a NOTHING
- */
- if ( startbranch == first ) {
- regnode *opt;
- /* the entire thing is a NOTHING sequence,
- * something like this: (?:|) So we can
- * turn it into a plain NOTHING op. */
- DEBUG_TRIE_COMPILE_r({
- regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
- Perl_re_indentf( aTHX_ "- %s (%d) <NOTHING BRANCH SEQUENCE>\n",
- depth+1,
- SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur));
-
- });
- OP(startbranch)= NOTHING;
- NEXT_OFF(startbranch)= tail - startbranch;
- for ( opt= startbranch + 1; opt < tail ; opt++ )
- OP(opt)= OPTIMIZED;
- }
- }
- } /* end if ( prev) */
- } /* TRIE_MAXBUF is non zero */
- } /* do trie */
-
- }
- else if ( code == BRANCHJ ) { /* single branch is optimized. */
- scan = NEXTOPER(NEXTOPER(scan));
- } else /* single branch is optimized. */
- scan = NEXTOPER(scan);
- continue;
- } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB) {
- I32 paren = 0;
- regnode *start = NULL;
- regnode *end = NULL;
- U32 my_recursed_depth= recursed_depth;
-
- if (OP(scan) != SUSPEND) { /* GOSUB */
- /* Do setup, note this code has side effects beyond
- * the rest of this block. Specifically setting
- * RExC_recurse[] must happen at least once during
- * study_chunk(). */
- paren = ARG(scan);
- RExC_recurse[ARG2L(scan)] = scan;
- start = REGNODE_p(RExC_open_parens[paren]);
- end = REGNODE_p(RExC_close_parens[paren]);
-
- /* NOTE we MUST always execute the above code, even
- * if we do nothing with a GOSUB */
- if (
- ( flags & SCF_IN_DEFINE )
- ||
- (
- (is_inf_internal || is_inf || (data && data->flags & SF_IS_INF))
- &&
- ( (flags & (SCF_DO_STCLASS | SCF_DO_SUBSTR)) == 0 )
- )
- ) {
- /* no need to do anything here if we are in a define. */
- /* or we are after some kind of infinite construct
- * so we can skip recursing into this item.
- * Since it is infinite we will not change the maxlen
- * or delta, and if we miss something that might raise
- * the minlen it will merely pessimise a little.
- *
- * Iow /(?(DEFINE)(?<foo>foo|food))a+(?&foo)/
- * might result in a minlen of 1 and not of 4,
- * but this doesn't make us mismatch, just try a bit
- * harder than we should.
- *
- * However we must assume this GOSUB is infinite, to
- * avoid wrongly applying other optimizations in the
- * enclosing scope - see GH 18096, for example.
- */
- is_inf = is_inf_internal = 1;
- scan= regnext(scan);
- continue;
- }
-
- if (
- !recursed_depth
- || !PAREN_TEST(recursed_depth - 1, paren)
- ) {
- /* it is quite possible that there are more efficient ways
- * to do this. We maintain a bitmap per level of recursion
- * of which patterns we have entered so we can detect if a
- * pattern creates a possible infinite loop. When we
- * recurse down a level we copy the previous levels bitmap
- * down. When we are at recursion level 0 we zero the top
- * level bitmap. It would be nice to implement a different
- * more efficient way of doing this. In particular the top
- * level bitmap may be unnecessary.
- */
- if (!recursed_depth) {
- Zero(RExC_study_chunk_recursed, RExC_study_chunk_recursed_bytes, U8);
- } else {
- Copy(PAREN_OFFSET(recursed_depth - 1),
- PAREN_OFFSET(recursed_depth),
- RExC_study_chunk_recursed_bytes, U8);
- }
- /* we havent recursed into this paren yet, so recurse into it */
- DEBUG_STUDYDATA("gosub-set", data, depth, is_inf);
- PAREN_SET(recursed_depth, paren);
- my_recursed_depth= recursed_depth + 1;
- } else {
- DEBUG_STUDYDATA("gosub-inf", data, depth, is_inf);
- /* some form of infinite recursion, assume infinite length
- * */
- if (flags & SCF_DO_SUBSTR) {
- scan_commit(pRExC_state, data, minlenp, is_inf);
- data->cur_is_floating = 1;
- }
- is_inf = is_inf_internal = 1;
- if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
- ssc_anything(data->start_class);
- flags &= ~SCF_DO_STCLASS;
-
- start= NULL; /* reset start so we dont recurse later on. */
- }
- } else {
- paren = stopparen;
- start = scan + 2;
- end = regnext(scan);
- }
- if (start) {
- scan_frame *newframe;
- assert(end);
- if (!RExC_frame_last) {
- Newxz(newframe, 1, scan_frame);
- SAVEDESTRUCTOR_X(S_unwind_scan_frames, newframe);
- RExC_frame_head= newframe;
- RExC_frame_count++;
- } else if (!RExC_frame_last->next_frame) {
- Newxz(newframe, 1, scan_frame);
- RExC_frame_last->next_frame= newframe;
- newframe->prev_frame= RExC_frame_last;
- RExC_frame_count++;
- } else {
- newframe= RExC_frame_last->next_frame;
- }
- RExC_frame_last= newframe;
-
- newframe->next_regnode = regnext(scan);
- newframe->last_regnode = last;
- newframe->stopparen = stopparen;
- newframe->prev_recursed_depth = recursed_depth;
- newframe->this_prev_frame= frame;
- newframe->in_gosub = (
- (frame && frame->in_gosub) || OP(scan) == GOSUB
- );
-
- DEBUG_STUDYDATA("frame-new", data, depth, is_inf);
- DEBUG_PEEP("fnew", scan, depth, flags);
-
- frame = newframe;
- scan = start;
- stopparen = paren;
- last = end;
- depth = depth + 1;
- recursed_depth= my_recursed_depth;
-
- continue;
- }
- }
- else if (PL_regkind[OP(scan)] == EXACT && ! isEXACTFish(OP(scan))) {
- SSize_t bytelen = STR_LEN(scan), charlen;
- UV uc;
- assert(bytelen);
- if (UTF) {
- const U8 * const s = (U8*)STRING(scan);
- uc = utf8_to_uvchr_buf(s, s + bytelen, NULL);
- charlen = utf8_length(s, s + bytelen);
- } else {
- uc = *((U8*)STRING(scan));
- charlen = bytelen;
- }
- min += charlen;
- if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
- /* The code below prefers earlier match for fixed
- offset, later match for variable offset. */
- if (data->last_end == -1) { /* Update the start info. */
- data->last_start_min = data->pos_min;
- data->last_start_max =
- is_inf ? OPTIMIZE_INFTY
- : (data->pos_delta > OPTIMIZE_INFTY - data->pos_min)
- ? OPTIMIZE_INFTY : data->pos_min + data->pos_delta;
- }
- sv_catpvn(data->last_found, STRING(scan), bytelen);
- if (UTF)
- SvUTF8_on(data->last_found);
- {
- SV * const sv = data->last_found;
- MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
- mg_find(sv, PERL_MAGIC_utf8) : NULL;
- if (mg && mg->mg_len >= 0)
- mg->mg_len += charlen;
- }
- data->last_end = data->pos_min + charlen;
- data->pos_min += charlen; /* As in the first entry. */
- data->flags &= ~SF_BEFORE_EOL;
- }
-
- /* ANDing the code point leaves at most it, and not in locale, and
- * can't match null string */
- if (flags & SCF_DO_STCLASS_AND) {
- ssc_cp_and(data->start_class, uc);
- ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
- ssc_clear_locale(data->start_class);
- }
- else if (flags & SCF_DO_STCLASS_OR) {
- ssc_add_cp(data->start_class, uc);
- ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
-
- /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
- ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
- }
- flags &= ~SCF_DO_STCLASS;
- }
- else if (PL_regkind[OP(scan)] == EXACT) {
- /* But OP != EXACT!, so is EXACTFish */
- SSize_t bytelen = STR_LEN(scan), charlen;
- const U8 * s = (U8*)STRING(scan);
-
- /* Replace a length 1 ASCII fold pair node with an ANYOFM node,
- * with the mask set to the complement of the bit that differs
- * between upper and lower case, and the lowest code point of the
- * pair (which the '&' forces) */
- if ( bytelen == 1
- && isALPHA_A(*s)
- && ( OP(scan) == EXACTFAA
- || ( OP(scan) == EXACTFU
- && ! HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(*s)))
- && mutate_ok
- ) {
- U8 mask = ~ ('A' ^ 'a'); /* These differ in just one bit */
-
- OP(scan) = ANYOFM;
- ARG_SET(scan, *s & mask);
- FLAGS(scan) = mask;
- /* we're not EXACTFish any more, so restudy */
- continue;
- }
-
- /* Search for fixed substrings supports EXACT only. */
- if (flags & SCF_DO_SUBSTR) {
- assert(data);
- scan_commit(pRExC_state, data, minlenp, is_inf);
- }
- charlen = UTF ? (SSize_t) utf8_length(s, s + bytelen) : bytelen;
- if (unfolded_multi_char) {
- RExC_seen |= REG_UNFOLDED_MULTI_SEEN;
- }
- min += charlen - min_subtract;
- assert (min >= 0);
- delta += min_subtract;
- if (flags & SCF_DO_SUBSTR) {
- data->pos_min += charlen - min_subtract;
- if (data->pos_min < 0) {
- data->pos_min = 0;
- }
- data->pos_delta += min_subtract;
- if (min_subtract) {
- data->cur_is_floating = 1; /* float */
- }
- }
-
- if (flags & SCF_DO_STCLASS) {
- SV* EXACTF_invlist = make_exactf_invlist(pRExC_state, scan);
-
- assert(EXACTF_invlist);
- if (flags & SCF_DO_STCLASS_AND) {
- if (OP(scan) != EXACTFL)
- ssc_clear_locale(data->start_class);
- ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
- ANYOF_POSIXL_ZERO(data->start_class);
- ssc_intersection(data->start_class, EXACTF_invlist, FALSE);
- }
- else { /* SCF_DO_STCLASS_OR */
- ssc_union(data->start_class, EXACTF_invlist, FALSE);
- ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
-
- /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
- ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
- }
- flags &= ~SCF_DO_STCLASS;
- SvREFCNT_dec(EXACTF_invlist);
- }
- }
- else if (REGNODE_VARIES(OP(scan))) {
- SSize_t mincount, maxcount, minnext, deltanext, pos_before = 0;
- I32 fl = 0, f = flags;
- regnode * const oscan = scan;
- regnode_ssc this_class;
- regnode_ssc *oclass = NULL;
- I32 next_is_eval = 0;
-
- switch (PL_regkind[OP(scan)]) {
- case WHILEM: /* End of (?:...)* . */
- scan = NEXTOPER(scan);
- goto finish;
- case PLUS:
- if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
- next = NEXTOPER(scan);
- if ( ( PL_regkind[OP(next)] == EXACT
- && ! isEXACTFish(OP(next)))
- || (flags & SCF_DO_STCLASS))
- {
- mincount = 1;
- maxcount = REG_INFTY;
- next = regnext(scan);
- scan = NEXTOPER(scan);
- goto do_curly;
- }
- }
- if (flags & SCF_DO_SUBSTR)
- data->pos_min++;
- /* This will bypass the formal 'min += minnext * mincount'
- * calculation in the do_curly path, so assumes min width
- * of the PLUS payload is exactly one. */
- min++;
- /* FALLTHROUGH */
- case STAR:
- next = NEXTOPER(scan);
-
- /* This temporary node can now be turned into EXACTFU, and
- * must, as regexec.c doesn't handle it */
- if (OP(next) == EXACTFU_S_EDGE && mutate_ok) {
- OP(next) = EXACTFU;
- }
-
- if ( STR_LEN(next) == 1
- && isALPHA_A(* STRING(next))
- && ( OP(next) == EXACTFAA
- || ( OP(next) == EXACTFU
- && ! HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(* STRING(next))))
- && mutate_ok
- ) {
- /* These differ in just one bit */
- U8 mask = ~ ('A' ^ 'a');
-
- assert(isALPHA_A(* STRING(next)));
-
- /* Then replace it by an ANYOFM node, with
- * the mask set to the complement of the
- * bit that differs between upper and lower
- * case, and the lowest code point of the
- * pair (which the '&' forces) */
- OP(next) = ANYOFM;
- ARG_SET(next, *STRING(next) & mask);
- FLAGS(next) = mask;
- }
-
- if (flags & SCF_DO_STCLASS) {
- mincount = 0;
- maxcount = REG_INFTY;
- next = regnext(scan);
- scan = NEXTOPER(scan);
- goto do_curly;
- }
- if (flags & SCF_DO_SUBSTR) {
- scan_commit(pRExC_state, data, minlenp, is_inf);
- /* Cannot extend fixed substrings */
- data->cur_is_floating = 1; /* float */
- }
- is_inf = is_inf_internal = 1;
- scan = regnext(scan);
- goto optimize_curly_tail;
- case CURLY:
- if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
- && (scan->flags == stopparen))
- {
- mincount = 1;
- maxcount = 1;
- } else {
- mincount = ARG1(scan);
- maxcount = ARG2(scan);
- }
- next = regnext(scan);
- if (OP(scan) == CURLYX) {
- I32 lp = (data ? *(data->last_closep) : 0);
- scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
- }
- scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
- next_is_eval = (OP(scan) == EVAL);
- do_curly:
- if (flags & SCF_DO_SUBSTR) {
- if (mincount == 0)
- scan_commit(pRExC_state, data, minlenp, is_inf);
- /* Cannot extend fixed substrings */
- pos_before = data->pos_min;
- }
- if (data) {
- fl = data->flags;
- data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
- if (is_inf)
- data->flags |= SF_IS_INF;
- }
- if (flags & SCF_DO_STCLASS) {
- ssc_init(pRExC_state, &this_class);
- oclass = data->start_class;
- data->start_class = &this_class;
- f |= SCF_DO_STCLASS_AND;
- f &= ~SCF_DO_STCLASS_OR;
- }
- /* Exclude from super-linear cache processing any {n,m}
- regops for which the combination of input pos and regex
- pos is not enough information to determine if a match
- will be possible.
-
- For example, in the regex /foo(bar\s*){4,8}baz/ with the
- regex pos at the \s*, the prospects for a match depend not
- only on the input position but also on how many (bar\s*)
- repeats into the {4,8} we are. */
- if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
- f &= ~SCF_WHILEM_VISITED_POS;
-
- /* This will finish on WHILEM, setting scan, or on NULL: */
- /* recurse study_chunk() on loop bodies */
- minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
- last, data, stopparen, recursed_depth, NULL,
- (mincount == 0
- ? (f & ~SCF_DO_SUBSTR)
- : f)
- , depth+1, mutate_ok);
-
- if (flags & SCF_DO_STCLASS)
- data->start_class = oclass;
- if (mincount == 0 || minnext == 0) {
- if (flags & SCF_DO_STCLASS_OR) {
- ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
- }
- else if (flags & SCF_DO_STCLASS_AND) {
- /* Switch to OR mode: cache the old value of
- * data->start_class */
- INIT_AND_WITHP;
- StructCopy(data->start_class, and_withp, regnode_ssc);
- flags &= ~SCF_DO_STCLASS_AND;
- StructCopy(&this_class, data->start_class, regnode_ssc);
- flags |= SCF_DO_STCLASS_OR;
- ANYOF_FLAGS(data->start_class)
- |= SSC_MATCHES_EMPTY_STRING;
- }
- } else { /* Non-zero len */
- if (flags & SCF_DO_STCLASS_OR) {
- ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
- ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
- }
- else if (flags & SCF_DO_STCLASS_AND)
- ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
- flags &= ~SCF_DO_STCLASS;
- }
- if (!scan) /* It was not CURLYX, but CURLY. */
- scan = next;
- if (((flags & (SCF_TRIE_DOING_RESTUDY|SCF_DO_SUBSTR))==SCF_DO_SUBSTR)
- /* ? quantifier ok, except for (?{ ... }) */
- && (next_is_eval || !(mincount == 0 && maxcount == 1))
- && (minnext == 0) && (deltanext == 0)
- && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
- && maxcount <= REG_INFTY/3) /* Complement check for big
- count */
- {
- _WARN_HELPER(RExC_precomp_end, packWARN(WARN_REGEXP),
- Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
- "Quantifier unexpected on zero-length expression "
- "in regex m/%" UTF8f "/",
- UTF8fARG(UTF, RExC_precomp_end - RExC_precomp,
- RExC_precomp)));
- }
-
- if ( ( minnext > 0 && mincount >= SSize_t_MAX / minnext )
- || min >= SSize_t_MAX - minnext * mincount )
- {
- FAIL("Regexp out of space");
- }
-
- min += minnext * mincount;
- is_inf_internal |= deltanext == OPTIMIZE_INFTY
- || (maxcount == REG_INFTY && minnext + deltanext > 0);
- is_inf |= is_inf_internal;
- if (is_inf) {
- delta = OPTIMIZE_INFTY;
- } else {
- delta += (minnext + deltanext) * maxcount
- - minnext * mincount;
- }
- /* Try powerful optimization CURLYX => CURLYN. */
- if ( OP(oscan) == CURLYX && data
- && data->flags & SF_IN_PAR
- && !(data->flags & SF_HAS_EVAL)
- && !deltanext && minnext == 1
- && mutate_ok
- ) {
- /* Try to optimize to CURLYN. */
- regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
- regnode * const nxt1 = nxt;
-#ifdef DEBUGGING
- regnode *nxt2;
-#endif
-
- /* Skip open. */
- nxt = regnext(nxt);
- if (!REGNODE_SIMPLE(OP(nxt))
- && !(PL_regkind[OP(nxt)] == EXACT
- && STR_LEN(nxt) == 1))
- goto nogo;
-#ifdef DEBUGGING
- nxt2 = nxt;
-#endif
- nxt = regnext(nxt);
- if (OP(nxt) != CLOSE)
- goto nogo;
- if (RExC_open_parens) {
-
- /*open->CURLYM*/
- RExC_open_parens[ARG(nxt1)] = REGNODE_OFFSET(oscan);
-
- /*close->while*/
- RExC_close_parens[ARG(nxt1)] = REGNODE_OFFSET(nxt) + 2;
- }
- /* Now we know that nxt2 is the only contents: */
- oscan->flags = (U8)ARG(nxt);
- OP(oscan) = CURLYN;
- OP(nxt1) = NOTHING; /* was OPEN. */
-
-#ifdef DEBUGGING
- OP(nxt1 + 1) = OPTIMIZED; /* was count. */
- NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
- NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
- OP(nxt) = OPTIMIZED; /* was CLOSE. */
- OP(nxt + 1) = OPTIMIZED; /* was count. */
- NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
-#endif
- }
- nogo:
-
- /* Try optimization CURLYX => CURLYM. */
- if ( OP(oscan) == CURLYX && data
- && !(data->flags & SF_HAS_PAR)
- && !(data->flags & SF_HAS_EVAL)
- && !deltanext /* atom is fixed width */
- && minnext != 0 /* CURLYM can't handle zero width */
- /* Nor characters whose fold at run-time may be
- * multi-character */
- && ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN)
- && mutate_ok
- ) {
- /* XXXX How to optimize if data == 0? */
- /* Optimize to a simpler form. */
- regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
- regnode *nxt2;
-
- OP(oscan) = CURLYM;
- while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
- && (OP(nxt2) != WHILEM))
- nxt = nxt2;
- OP(nxt2) = SUCCEED; /* Whas WHILEM */
- /* Need to optimize away parenths. */
- if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
- /* Set the parenth number. */
- regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
-
- oscan->flags = (U8)ARG(nxt);
- if (RExC_open_parens) {
- /*open->CURLYM*/
- RExC_open_parens[ARG(nxt1)] = REGNODE_OFFSET(oscan);
-
- /*close->NOTHING*/
- RExC_close_parens[ARG(nxt1)] = REGNODE_OFFSET(nxt2)
- + 1;
- }
- OP(nxt1) = OPTIMIZED; /* was OPEN. */
- OP(nxt) = OPTIMIZED; /* was CLOSE. */
-
-#ifdef DEBUGGING
- OP(nxt1 + 1) = OPTIMIZED; /* was count. */
- OP(nxt + 1) = OPTIMIZED; /* was count. */
- NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
- NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
-#endif
-#if 0
- while ( nxt1 && (OP(nxt1) != WHILEM)) {
- regnode *nnxt = regnext(nxt1);
- if (nnxt == nxt) {
- if (reg_off_by_arg[OP(nxt1)])
- ARG_SET(nxt1, nxt2 - nxt1);
- else if (nxt2 - nxt1 < U16_MAX)
- NEXT_OFF(nxt1) = nxt2 - nxt1;
- else
- OP(nxt) = NOTHING; /* Cannot beautify */
- }
- nxt1 = nnxt;
- }
-#endif
- /* Optimize again: */
- /* recurse study_chunk() on optimised CURLYX => CURLYM */
- study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
- NULL, stopparen, recursed_depth, NULL, 0,
- depth+1, mutate_ok);
- }
- else
- oscan->flags = 0;
- }
- else if ((OP(oscan) == CURLYX)
- && (flags & SCF_WHILEM_VISITED_POS)
- /* See the comment on a similar expression above.
- However, this time it's not a subexpression
- we care about, but the expression itself. */
- && (maxcount == REG_INFTY)
- && data) {
- /* This stays as CURLYX, we can put the count/of pair. */
- /* Find WHILEM (as in regexec.c) */
- regnode *nxt = oscan + NEXT_OFF(oscan);
-
- if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
- nxt += ARG(nxt);
- nxt = PREVOPER(nxt);
- if (nxt->flags & 0xf) {
- /* we've already set whilem count on this node */
- } else if (++data->whilem_c < 16) {
- assert(data->whilem_c <= RExC_whilem_seen);
- nxt->flags = (U8)(data->whilem_c
- | (RExC_whilem_seen << 4)); /* On WHILEM */
- }
- }
- if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
- pars++;
- if (flags & SCF_DO_SUBSTR) {
- SV *last_str = NULL;
- STRLEN last_chrs = 0;
- int counted = mincount != 0;
-
- if (data->last_end > 0 && mincount != 0) { /* Ends with a
- string. */
- SSize_t b = pos_before >= data->last_start_min
- ? pos_before : data->last_start_min;
- STRLEN l;
- const char * const s = SvPV_const(data->last_found, l);
- SSize_t old = b - data->last_start_min;
- assert(old >= 0);
-
- if (UTF)
- old = utf8_hop_forward((U8*)s, old,
- (U8 *) SvEND(data->last_found))
- - (U8*)s;
- l -= old;
- /* Get the added string: */
- last_str = newSVpvn_utf8(s + old, l, UTF);
- last_chrs = UTF ? utf8_length((U8*)(s + old),
- (U8*)(s + old + l)) : l;
- if (deltanext == 0 && pos_before == b) {
- /* What was added is a constant string */
- if (mincount > 1) {
-
- SvGROW(last_str, (mincount * l) + 1);
- repeatcpy(SvPVX(last_str) + l,
- SvPVX_const(last_str), l,
- mincount - 1);
- SvCUR_set(last_str, SvCUR(last_str) * mincount);
- /* Add additional parts. */
- SvCUR_set(data->last_found,
- SvCUR(data->last_found) - l);
- sv_catsv(data->last_found, last_str);
- {
- SV * sv = data->last_found;
- MAGIC *mg =
- SvUTF8(sv) && SvMAGICAL(sv) ?
- mg_find(sv, PERL_MAGIC_utf8) : NULL;
- if (mg && mg->mg_len >= 0)
- mg->mg_len += last_chrs * (mincount-1);
- }
- last_chrs *= mincount;
- data->last_end += l * (mincount - 1);
- }
- } else {
- /* start offset must point into the last copy */
- data->last_start_min += minnext * (mincount - 1);
- data->last_start_max =
- is_inf
- ? OPTIMIZE_INFTY
- : data->last_start_max +
- (maxcount - 1) * (minnext + data->pos_delta);
- }
- }
- /* It is counted once already... */
- data->pos_min += minnext * (mincount - counted);
-#if 0
-Perl_re_printf( aTHX_ "counted=%" UVuf " deltanext=%" UVuf
- " OPTIMIZE_INFTY=%" UVuf " minnext=%" UVuf
- " maxcount=%" UVuf " mincount=%" UVuf "\n",
- (UV)counted, (UV)deltanext, (UV)OPTIMIZE_INFTY, (UV)minnext, (UV)maxcount,
- (UV)mincount);
-if (deltanext != OPTIMIZE_INFTY)
-Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n",
- (UV)(-counted * deltanext + (minnext + deltanext) * maxcount
- - minnext * mincount), (UV)(OPTIMIZE_INFTY - data->pos_delta));
-#endif
- if (deltanext == OPTIMIZE_INFTY
- || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= OPTIMIZE_INFTY - data->pos_delta)
- data->pos_delta = OPTIMIZE_INFTY;
- else
- data->pos_delta += - counted * deltanext +
- (minnext + deltanext) * maxcount - minnext * mincount;
- if (mincount != maxcount) {
- /* Cannot extend fixed substrings found inside
- the group. */
- scan_commit(pRExC_state, data, minlenp, is_inf);
- if (mincount && last_str) {
- SV * const sv = data->last_found;
- MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
- mg_find(sv, PERL_MAGIC_utf8) : NULL;
-
- if (mg)
- mg->mg_len = -1;
- sv_setsv(sv, last_str);
- data->last_end = data->pos_min;
- data->last_start_min = data->pos_min - last_chrs;
- data->last_start_max = is_inf
- ? OPTIMIZE_INFTY
- : data->pos_min + data->pos_delta - last_chrs;
- }
- data->cur_is_floating = 1; /* float */
- }
- SvREFCNT_dec(last_str);
- }
- if (data && (fl & SF_HAS_EVAL))
- data->flags |= SF_HAS_EVAL;
- optimize_curly_tail:
- rck_elide_nothing(oscan);
- continue;
-
- default:
- Perl_croak(aTHX_ "panic: unexpected varying REx opcode %d",
- OP(scan));
- case REF:
- case CLUMP:
- if (flags & SCF_DO_SUBSTR) {
- /* Cannot expect anything... */
- scan_commit(pRExC_state, data, minlenp, is_inf);
- data->cur_is_floating = 1; /* float */
- }
- is_inf = is_inf_internal = 1;
- if (flags & SCF_DO_STCLASS_OR) {
- if (OP(scan) == CLUMP) {
- /* Actually is any start char, but very few code points
- * aren't start characters */
- ssc_match_all_cp(data->start_class);
- }
- else {
- ssc_anything(data->start_class);
- }
- }
- flags &= ~SCF_DO_STCLASS;
- break;
- }
- }
- else if (OP(scan) == LNBREAK) {
- if (flags & SCF_DO_STCLASS) {
- if (flags & SCF_DO_STCLASS_AND) {
- ssc_intersection(data->start_class,
- PL_XPosix_ptrs[_CC_VERTSPACE], FALSE);
- ssc_clear_locale(data->start_class);
- ANYOF_FLAGS(data->start_class)
- &= ~SSC_MATCHES_EMPTY_STRING;
- }
- else if (flags & SCF_DO_STCLASS_OR) {
- ssc_union(data->start_class,
- PL_XPosix_ptrs[_CC_VERTSPACE],
- FALSE);
- ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
-
- /* See commit msg for
- * 749e076fceedeb708a624933726e7989f2302f6a */
- ANYOF_FLAGS(data->start_class)
- &= ~SSC_MATCHES_EMPTY_STRING;
- }
- flags &= ~SCF_DO_STCLASS;
- }
- min++;
- if (delta != OPTIMIZE_INFTY)
- delta++; /* Because of the 2 char string cr-lf */
- if (flags & SCF_DO_SUBSTR) {
- /* Cannot expect anything... */
- scan_commit(pRExC_state, data, minlenp, is_inf);
- data->pos_min += 1;
- if (data->pos_delta != OPTIMIZE_INFTY) {
- data->pos_delta += 1;
- }
- data->cur_is_floating = 1; /* float */
- }
- }
- else if (REGNODE_SIMPLE(OP(scan))) {
-
- if (flags & SCF_DO_SUBSTR) {
- scan_commit(pRExC_state, data, minlenp, is_inf);
- data->pos_min++;
- }
- min++;
- if (flags & SCF_DO_STCLASS) {
- bool invert = 0;
- SV* my_invlist = NULL;
- U8 namedclass;
-
- /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
- ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
-
- /* Some of the logic below assumes that switching
- locale on will only add false positives. */
- switch (OP(scan)) {
-
- default:
-#ifdef DEBUGGING
- Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d",
- OP(scan));
-#endif
- case SANY:
- if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
- ssc_match_all_cp(data->start_class);
- break;
-
- case REG_ANY:
- {
- SV* REG_ANY_invlist = _new_invlist(2);
- REG_ANY_invlist = add_cp_to_invlist(REG_ANY_invlist,
- '\n');
- if (flags & SCF_DO_STCLASS_OR) {
- ssc_union(data->start_class,
- REG_ANY_invlist,
- TRUE /* TRUE => invert, hence all but \n
- */
- );
- }
- else if (flags & SCF_DO_STCLASS_AND) {
- ssc_intersection(data->start_class,
- REG_ANY_invlist,
- TRUE /* TRUE => invert */
- );
- ssc_clear_locale(data->start_class);
- }
- SvREFCNT_dec_NN(REG_ANY_invlist);
- }
- break;
-
- case ANYOFD:
- case ANYOFL:
- case ANYOFPOSIXL:
- case ANYOFH:
- case ANYOFHb:
- case ANYOFHr:
- case ANYOFHs:
- case ANYOF:
- if (flags & SCF_DO_STCLASS_AND)
- ssc_and(pRExC_state, data->start_class,
- (regnode_charclass *) scan);
- else
- ssc_or(pRExC_state, data->start_class,
- (regnode_charclass *) scan);
- break;
-
- case NANYOFM: /* NANYOFM already contains the inversion of the
- input ANYOF data, so, unlike things like
- NPOSIXA, don't change 'invert' to TRUE */
- /* FALLTHROUGH */
- case ANYOFM:
- {
- SV* cp_list = get_ANYOFM_contents(scan);
-
- if (flags & SCF_DO_STCLASS_OR) {
- ssc_union(data->start_class, cp_list, invert);
- }
- else if (flags & SCF_DO_STCLASS_AND) {
- ssc_intersection(data->start_class, cp_list, invert);
- }
-
- SvREFCNT_dec_NN(cp_list);
- break;
- }
-
- case ANYOFR:
- case ANYOFRb:
- {
- SV* cp_list = NULL;
-
- cp_list = _add_range_to_invlist(cp_list,
- ANYOFRbase(scan),
- ANYOFRbase(scan) + ANYOFRdelta(scan));
-
- if (flags & SCF_DO_STCLASS_OR) {
- ssc_union(data->start_class, cp_list, invert);
- }
- else if (flags & SCF_DO_STCLASS_AND) {
- ssc_intersection(data->start_class, cp_list, invert);
- }
-
- SvREFCNT_dec_NN(cp_list);
- break;
- }
-
- case NPOSIXL:
- invert = 1;
- /* FALLTHROUGH */
-
- case POSIXL:
- namedclass = classnum_to_namedclass(FLAGS(scan)) + invert;
- if (flags & SCF_DO_STCLASS_AND) {
- bool was_there = cBOOL(
- ANYOF_POSIXL_TEST(data->start_class,
- namedclass));
- ANYOF_POSIXL_ZERO(data->start_class);
- if (was_there) { /* Do an AND */
- ANYOF_POSIXL_SET(data->start_class, namedclass);
- }
- /* No individual code points can now match */
- data->start_class->invlist
- = sv_2mortal(_new_invlist(0));
- }
- else {
- int complement = namedclass + ((invert) ? -1 : 1);
-
- assert(flags & SCF_DO_STCLASS_OR);
-
- /* If the complement of this class was already there,
- * the result is that they match all code points,
- * (\d + \D == everything). Remove the classes from
- * future consideration. Locale is not relevant in
- * this case */
- if (ANYOF_POSIXL_TEST(data->start_class, complement)) {
- ssc_match_all_cp(data->start_class);
- ANYOF_POSIXL_CLEAR(data->start_class, namedclass);
- ANYOF_POSIXL_CLEAR(data->start_class, complement);
- }
- else { /* The usual case; just add this class to the
- existing set */
- ANYOF_POSIXL_SET(data->start_class, namedclass);
- }
- }
- break;
-
- case NPOSIXA: /* For these, we always know the exact set of
- what's matched */
- invert = 1;
- /* FALLTHROUGH */
- case POSIXA:
- my_invlist = invlist_clone(PL_Posix_ptrs[FLAGS(scan)], NULL);
- goto join_posix_and_ascii;
-
- case NPOSIXD:
- case NPOSIXU:
- invert = 1;
- /* FALLTHROUGH */
- case POSIXD:
- case POSIXU:
- my_invlist = invlist_clone(PL_XPosix_ptrs[FLAGS(scan)], NULL);
-
- /* NPOSIXD matches all upper Latin1 code points unless the
- * target string being matched is UTF-8, which is
- * unknowable until match time. Since we are going to
- * invert, we want to get rid of all of them so that the
- * inversion will match all */
- if (OP(scan) == NPOSIXD) {
- _invlist_subtract(my_invlist, PL_UpperLatin1,
- &my_invlist);
- }
-
- join_posix_and_ascii:
-
- if (flags & SCF_DO_STCLASS_AND) {
- ssc_intersection(data->start_class, my_invlist, invert);
- ssc_clear_locale(data->start_class);
- }
- else {
- assert(flags & SCF_DO_STCLASS_OR);
- ssc_union(data->start_class, my_invlist, invert);
- }
- SvREFCNT_dec(my_invlist);
- }
- if (flags & SCF_DO_STCLASS_OR)
- ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
- flags &= ~SCF_DO_STCLASS;
- }
- }
- else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
- data->flags |= (OP(scan) == MEOL
- ? SF_BEFORE_MEOL
- : SF_BEFORE_SEOL);
- scan_commit(pRExC_state, data, minlenp, is_inf);
-
- }
- else if ( PL_regkind[OP(scan)] == BRANCHJ
- /* Lookbehind, or need to calculate parens/evals/stclass: */
- && (scan->flags || data || (flags & SCF_DO_STCLASS))
- && (OP(scan) == IFMATCH || OP(scan) == UNLESSM))
- {
- if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
- || OP(scan) == UNLESSM )
- {
- /* Negative Lookahead/lookbehind
- In this case we can't do fixed string optimisation.
- */
-
- SSize_t deltanext, minnext, fake = 0;
- regnode *nscan;
- regnode_ssc intrnl;
- int f = 0;
-
- StructCopy(&zero_scan_data, &data_fake, scan_data_t);
- if (data) {
- data_fake.whilem_c = data->whilem_c;
- data_fake.last_closep = data->last_closep;
- }
- else
- data_fake.last_closep = &fake;
- data_fake.pos_delta = delta;
- if ( flags & SCF_DO_STCLASS && !scan->flags
- && OP(scan) == IFMATCH ) { /* Lookahead */
- ssc_init(pRExC_state, &intrnl);
- data_fake.start_class = &intrnl;
- f |= SCF_DO_STCLASS_AND;
- }
- if (flags & SCF_WHILEM_VISITED_POS)
- f |= SCF_WHILEM_VISITED_POS;
- next = regnext(scan);
- nscan = NEXTOPER(NEXTOPER(scan));
-
- /* recurse study_chunk() for lookahead body */
- minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
- last, &data_fake, stopparen,
- recursed_depth, NULL, f, depth+1,
- mutate_ok);
- if (scan->flags) {
- if ( deltanext < 0
- || deltanext > (I32) U8_MAX
- || minnext > (I32)U8_MAX
- || minnext + deltanext > (I32)U8_MAX)
- {
- FAIL2("Lookbehind longer than %" UVuf " not implemented",
- (UV)U8_MAX);
- }
-
- /* The 'next_off' field has been repurposed to count the
- * additional starting positions to try beyond the initial
- * one. (This leaves it at 0 for non-variable length
- * matches to avoid breakage for those not using this
- * extension) */
- if (deltanext) {
- scan->next_off = deltanext;
- ckWARNexperimental(RExC_parse,
- WARN_EXPERIMENTAL__VLB,
- "Variable length lookbehind is experimental");
- }
- scan->flags = (U8)minnext + deltanext;
- }
- if (data) {
- if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
- pars++;
- if (data_fake.flags & SF_HAS_EVAL)
- data->flags |= SF_HAS_EVAL;
- data->whilem_c = data_fake.whilem_c;
- }
- if (f & SCF_DO_STCLASS_AND) {
- if (flags & SCF_DO_STCLASS_OR) {
- /* OR before, AND after: ideally we would recurse with
- * data_fake to get the AND applied by study of the
- * remainder of the pattern, and then derecurse;
- * *** HACK *** for now just treat as "no information".
- * See [perl #56690].
- */
- ssc_init(pRExC_state, data->start_class);
- } else {
- /* AND before and after: combine and continue. These
- * assertions are zero-length, so can match an EMPTY
- * string */
- ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
- ANYOF_FLAGS(data->start_class)
- |= SSC_MATCHES_EMPTY_STRING;
- }
- }
- }
-#if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
- else {
- /* Positive Lookahead/lookbehind
- In this case we can do fixed string optimisation,
- but we must be careful about it. Note in the case of
- lookbehind the positions will be offset by the minimum
- length of the pattern, something we won't know about
- until after the recurse.
- */
- SSize_t deltanext, fake = 0;
- regnode *nscan;
- regnode_ssc intrnl;
- int f = 0;
- /* We use SAVEFREEPV so that when the full compile
- is finished perl will clean up the allocated
- minlens when it's all done. This way we don't
- have to worry about freeing them when we know
- they wont be used, which would be a pain.
- */
- SSize_t *minnextp;
- Newx( minnextp, 1, SSize_t );
- SAVEFREEPV(minnextp);
-
- if (data) {
- StructCopy(data, &data_fake, scan_data_t);
- if ((flags & SCF_DO_SUBSTR) && data->last_found) {
- f |= SCF_DO_SUBSTR;
- if (scan->flags)
- scan_commit(pRExC_state, &data_fake, minlenp, is_inf);
- data_fake.last_found=newSVsv(data->last_found);
- }
- }
- else
- data_fake.last_closep = &fake;
- data_fake.flags = 0;
- data_fake.substrs[0].flags = 0;
- data_fake.substrs[1].flags = 0;
- data_fake.pos_delta = delta;
- if (is_inf)
- data_fake.flags |= SF_IS_INF;
- if ( flags & SCF_DO_STCLASS && !scan->flags
- && OP(scan) == IFMATCH ) { /* Lookahead */
- ssc_init(pRExC_state, &intrnl);
- data_fake.start_class = &intrnl;
- f |= SCF_DO_STCLASS_AND;
- }
- if (flags & SCF_WHILEM_VISITED_POS)
- f |= SCF_WHILEM_VISITED_POS;
- next = regnext(scan);
- nscan = NEXTOPER(NEXTOPER(scan));
-
- /* positive lookahead study_chunk() recursion */
- *minnextp = study_chunk(pRExC_state, &nscan, minnextp,
- &deltanext, last, &data_fake,
- stopparen, recursed_depth, NULL,
- f, depth+1, mutate_ok);
- if (scan->flags) {
- assert(0); /* This code has never been tested since this
- is normally not compiled */
- if ( deltanext < 0
- || deltanext > (I32) U8_MAX
- || *minnextp > (I32)U8_MAX
- || *minnextp + deltanext > (I32)U8_MAX)
- {
- FAIL2("Lookbehind longer than %" UVuf " not implemented",
- (UV)U8_MAX);
- }
-
- if (deltanext) {
- scan->next_off = deltanext;
- }
- scan->flags = (U8)*minnextp + deltanext;
- }
-
- *minnextp += min;
-
- if (f & SCF_DO_STCLASS_AND) {
- ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
- ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING;
- }
- if (data) {
- if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
- pars++;
- if (data_fake.flags & SF_HAS_EVAL)
- data->flags |= SF_HAS_EVAL;
- data->whilem_c = data_fake.whilem_c;
- if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
- int i;
- if (RExC_rx->minlen<*minnextp)
- RExC_rx->minlen=*minnextp;
- scan_commit(pRExC_state, &data_fake, minnextp, is_inf);
- SvREFCNT_dec_NN(data_fake.last_found);
-
- for (i = 0; i < 2; i++) {
- if (data_fake.substrs[i].minlenp != minlenp) {
- data->substrs[i].min_offset =
- data_fake.substrs[i].min_offset;
- data->substrs[i].max_offset =
- data_fake.substrs[i].max_offset;
- data->substrs[i].minlenp =
- data_fake.substrs[i].minlenp;
- data->substrs[i].lookbehind += scan->flags;
- }
- }
- }
- }
- }
-#endif
- }
- else if (OP(scan) == OPEN) {
- if (stopparen != (I32)ARG(scan))
- pars++;
- }
- else if (OP(scan) == CLOSE) {
- if (stopparen == (I32)ARG(scan)) {
- break;
- }
- if ((I32)ARG(scan) == is_par) {
- next = regnext(scan);
-
- if ( next && (OP(next) != WHILEM) && next < last)
- is_par = 0; /* Disable optimization */
- }
- if (data)
- *(data->last_closep) = ARG(scan);
- }
- else if (OP(scan) == EVAL) {
- if (data)
- data->flags |= SF_HAS_EVAL;
- }
- else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
- if (flags & SCF_DO_SUBSTR) {
- scan_commit(pRExC_state, data, minlenp, is_inf);
- flags &= ~SCF_DO_SUBSTR;
- }
- if (data && OP(scan)==ACCEPT) {
- data->flags |= SCF_SEEN_ACCEPT;
- if (stopmin > min)
- stopmin = min;
- }
- }
- else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
- {
- if (flags & SCF_DO_SUBSTR) {
- scan_commit(pRExC_state, data, minlenp, is_inf);
- data->cur_is_floating = 1; /* float */
- }
- is_inf = is_inf_internal = 1;
- if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
- ssc_anything(data->start_class);
- flags &= ~SCF_DO_STCLASS;
- }
- else if (OP(scan) == GPOS) {
- if (!(RExC_rx->intflags & PREGf_GPOS_FLOAT) &&
- !(delta || is_inf || (data && data->pos_delta)))
- {
- if (!(RExC_rx->intflags & PREGf_ANCH) && (flags & SCF_DO_SUBSTR))
- RExC_rx->intflags |= PREGf_ANCH_GPOS;
- if (RExC_rx->gofs < (STRLEN)min)
- RExC_rx->gofs = min;
- } else {
- RExC_rx->intflags |= PREGf_GPOS_FLOAT;
- RExC_rx->gofs = 0;
- }
- }
-#ifdef TRIE_STUDY_OPT
-#ifdef FULL_TRIE_STUDY
- else if (PL_regkind[OP(scan)] == TRIE) {
- /* NOTE - There is similar code to this block above for handling
- BRANCH nodes on the initial study. If you change stuff here
- check there too. */
- regnode *trie_node= scan;
- regnode *tail= regnext(scan);
- reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
- SSize_t max1 = 0, min1 = OPTIMIZE_INFTY;
- regnode_ssc accum;
-
- if (flags & SCF_DO_SUBSTR) { /* XXXX Add !SUSPEND? */
- /* Cannot merge strings after this. */
- scan_commit(pRExC_state, data, minlenp, is_inf);
- }
- if (flags & SCF_DO_STCLASS)
- ssc_init_zero(pRExC_state, &accum);
-
- if (!trie->jump) {
- min1= trie->minlen;
- max1= trie->maxlen;
- } else {
- const regnode *nextbranch= NULL;
- U32 word;
-
- for ( word=1 ; word <= trie->wordcount ; word++)
- {
- SSize_t deltanext=0, minnext=0, f = 0, fake;
- regnode_ssc this_class;
-
- StructCopy(&zero_scan_data, &data_fake, scan_data_t);
- if (data) {
- data_fake.whilem_c = data->whilem_c;
- data_fake.last_closep = data->last_closep;
- }
- else
- data_fake.last_closep = &fake;
- data_fake.pos_delta = delta;
- if (flags & SCF_DO_STCLASS) {
- ssc_init(pRExC_state, &this_class);
- data_fake.start_class = &this_class;
- f = SCF_DO_STCLASS_AND;
- }
- if (flags & SCF_WHILEM_VISITED_POS)
- f |= SCF_WHILEM_VISITED_POS;
-
- if (trie->jump[word]) {
- if (!nextbranch)
- nextbranch = trie_node + trie->jump[0];
- scan= trie_node + trie->jump[word];
- /* We go from the jump point to the branch that follows
- it. Note this means we need the vestigal unused
- branches even though they arent otherwise used. */
- /* optimise study_chunk() for TRIE */
- minnext = study_chunk(pRExC_state, &scan, minlenp,
- &deltanext, (regnode *)nextbranch, &data_fake,
- stopparen, recursed_depth, NULL, f, depth+1,
- mutate_ok);
- }
- if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
- nextbranch= regnext((regnode*)nextbranch);
-
- if (min1 > (SSize_t)(minnext + trie->minlen))
- min1 = minnext + trie->minlen;
- if (deltanext == OPTIMIZE_INFTY) {
- is_inf = is_inf_internal = 1;
- max1 = OPTIMIZE_INFTY;
- } else if (max1 < (SSize_t)(minnext + deltanext + trie->maxlen))
- max1 = minnext + deltanext + trie->maxlen;
-
- if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
- pars++;
- if (data_fake.flags & SCF_SEEN_ACCEPT) {
- if ( stopmin > min + min1)
- stopmin = min + min1;
- flags &= ~SCF_DO_SUBSTR;
- if (data)
- data->flags |= SCF_SEEN_ACCEPT;
- }
- if (data) {
- if (data_fake.flags & SF_HAS_EVAL)
- data->flags |= SF_HAS_EVAL;
- data->whilem_c = data_fake.whilem_c;
- }
- if (flags & SCF_DO_STCLASS)
- ssc_or(pRExC_state, &accum, (regnode_charclass *) &this_class);
- }
- }
- if (flags & SCF_DO_SUBSTR) {
- data->pos_min += min1;
- data->pos_delta += max1 - min1;
- if (max1 != min1 || is_inf)
- data->cur_is_floating = 1; /* float */
- }
- min += min1;
- if (delta != OPTIMIZE_INFTY) {
- if (OPTIMIZE_INFTY - (max1 - min1) >= delta)
- delta += max1 - min1;
- else
- delta = OPTIMIZE_INFTY;
- }
- if (flags & SCF_DO_STCLASS_OR) {
- ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &accum);
- if (min1) {
- ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
- flags &= ~SCF_DO_STCLASS;
- }
- }
- else if (flags & SCF_DO_STCLASS_AND) {
- if (min1) {
- ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
- flags &= ~SCF_DO_STCLASS;
- }
- else {
- /* Switch to OR mode: cache the old value of
- * data->start_class */
- INIT_AND_WITHP;
- StructCopy(data->start_class, and_withp, regnode_ssc);
- flags &= ~SCF_DO_STCLASS_AND;
- StructCopy(&accum, data->start_class, regnode_ssc);
- flags |= SCF_DO_STCLASS_OR;
- }
- }
- scan= tail;
- continue;
- }
-#else
- else if (PL_regkind[OP(scan)] == TRIE) {
- reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
- U8*bang=NULL;
-
- min += trie->minlen;
- delta += (trie->maxlen - trie->minlen);
- flags &= ~SCF_DO_STCLASS; /* xxx */
- if (flags & SCF_DO_SUBSTR) {
- /* Cannot expect anything... */
- scan_commit(pRExC_state, data, minlenp, is_inf);
- data->pos_min += trie->minlen;
- data->pos_delta += (trie->maxlen - trie->minlen);
- if (trie->maxlen != trie->minlen)
- data->cur_is_floating = 1; /* float */
- }
- if (trie->jump) /* no more substrings -- for now /grr*/
- flags &= ~SCF_DO_SUBSTR;
- }
- else if (OP(scan) == REGEX_SET) {
- Perl_croak(aTHX_ "panic: %s regnode should be resolved"
- " before optimization", reg_name[REGEX_SET]);
- }
-
-#endif /* old or new */
-#endif /* TRIE_STUDY_OPT */
-
- /* Else: zero-length, ignore. */
- scan = regnext(scan);
- }
-
- finish:
- if (frame) {
- /* we need to unwind recursion. */
- depth = depth - 1;
-
- DEBUG_STUDYDATA("frame-end", data, depth, is_inf);
- DEBUG_PEEP("fend", scan, depth, flags);
-
- /* restore previous context */
- last = frame->last_regnode;
- scan = frame->next_regnode;
- stopparen = frame->stopparen;
- recursed_depth = frame->prev_recursed_depth;
-
- RExC_frame_last = frame->prev_frame;
- frame = frame->this_prev_frame;
- goto fake_study_recurse;
- }
-
- assert(!frame);
- DEBUG_STUDYDATA("pre-fin", data, depth, is_inf);
-
- *scanp = scan;
- *deltap = is_inf_internal ? OPTIMIZE_INFTY : delta;
-
- if (flags & SCF_DO_SUBSTR && is_inf)
- data->pos_delta = OPTIMIZE_INFTY - data->pos_min;
- if (is_par > (I32)U8_MAX)
- is_par = 0;
- if (is_par && pars==1 && data) {
- data->flags |= SF_IN_PAR;
- data->flags &= ~SF_HAS_PAR;
- }
- else if (pars && data) {
- data->flags |= SF_HAS_PAR;
- data->flags &= ~SF_IN_PAR;
- }
- if (flags & SCF_DO_STCLASS_OR)
- ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
- if (flags & SCF_TRIE_RESTUDY)
- data->flags |= SCF_TRIE_RESTUDY;
-
- DEBUG_STUDYDATA("post-fin", data, depth, is_inf);
-
- final_minlen = min < stopmin
- ? min : stopmin;
-
- if (!(RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)) {
- if (final_minlen > OPTIMIZE_INFTY - delta)
- RExC_maxlen = OPTIMIZE_INFTY;
- else if (RExC_maxlen < final_minlen + delta)
- RExC_maxlen = final_minlen + delta;
- }
- return final_minlen;
-}
-
-STATIC U32
-S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
-{
- U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
-
- PERL_ARGS_ASSERT_ADD_DATA;
-
- Renewc(RExC_rxi->data,
- sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
- char, struct reg_data);
- if(count)
- Renew(RExC_rxi->data->what, count + n, U8);
- else
- Newx(RExC_rxi->data->what, n, U8);
- RExC_rxi->data->count = count + n;
- Copy(s, RExC_rxi->data->what + count, n, U8);
- return count;
-}
-
-/*XXX: todo make this not included in a non debugging perl, but appears to be
- * used anyway there, in 'use re' */
-#ifndef PERL_IN_XSUB_RE
-void
-Perl_reginitcolors(pTHX)
-{
- const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
- if (s) {
- char *t = savepv(s);
- int i = 0;
- PL_colors[0] = t;
- while (++i < 6) {
- t = strchr(t, '\t');
- if (t) {
- *t = '\0';
- PL_colors[i] = ++t;
- }
- else
- PL_colors[i] = t = (char *)"";
- }
- } else {
- int i = 0;
- while (i < 6)
- PL_colors[i++] = (char *)"";
- }
- PL_colorset = 1;
-}
-#endif
-
-
-#ifdef TRIE_STUDY_OPT
-#define CHECK_RESTUDY_GOTO_butfirst(dOsomething) \
- STMT_START { \
- if ( \
- (data.flags & SCF_TRIE_RESTUDY) \
- && ! restudied++ \
- ) { \
- dOsomething; \
- goto reStudy; \
- } \
- } STMT_END
-#else
-#define CHECK_RESTUDY_GOTO_butfirst
-#endif
-
-/*
- * pregcomp - compile a regular expression into internal code
- *
- * Decides which engine's compiler to call based on the hint currently in
- * scope
- */
-
-#ifndef PERL_IN_XSUB_RE
-
-/* return the currently in-scope regex engine (or the default if none) */
-
-regexp_engine const *
-Perl_current_re_engine(pTHX)
-{
- if (IN_PERL_COMPILETIME) {
- HV * const table = GvHV(PL_hintgv);
- SV **ptr;
-
- if (!table || !(PL_hints & HINT_LOCALIZE_HH))
- return &PL_core_reg_engine;
- ptr = hv_fetchs(table, "regcomp", FALSE);
- if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
- return &PL_core_reg_engine;
- return INT2PTR(regexp_engine*, SvIV(*ptr));
- }
- else {
- SV *ptr;
- if (!PL_curcop->cop_hints_hash)
- return &PL_core_reg_engine;
- ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
- if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
- return &PL_core_reg_engine;
- return INT2PTR(regexp_engine*, SvIV(ptr));
- }
-}
-
-
-REGEXP *
-Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
-{
- regexp_engine const *eng = current_re_engine();
- DECLARE_AND_GET_RE_DEBUG_FLAGS;
-
- PERL_ARGS_ASSERT_PREGCOMP;
-
- /* Dispatch a request to compile a regexp to correct regexp engine. */
- DEBUG_COMPILE_r({
- Perl_re_printf( aTHX_ "Using engine %" UVxf "\n",
- PTR2UV(eng));
- });
- return CALLREGCOMP_ENG(eng, pattern, flags);
-}
-#endif
-
-/* public(ish) entry point for the perl core's own regex compiling code.
- * It's actually a wrapper for Perl_re_op_compile that only takes an SV
- * pattern rather than a list of OPs, and uses the internal engine rather
- * than the current one */
-
-REGEXP *
-Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
-{
- SV *pat = pattern; /* defeat constness! */
-
- PERL_ARGS_ASSERT_RE_COMPILE;
-
- return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
-#ifdef PERL_IN_XSUB_RE
- &my_reg_engine,
-#else
- &PL_core_reg_engine,
-#endif
- NULL, NULL, rx_flags, 0);
-}
-
-static void
-S_free_codeblocks(pTHX_ struct reg_code_blocks *cbs)
-{
- int n;
-
- if (--cbs->refcnt > 0)
- return;
- for (n = 0; n < cbs->count; n++) {
- REGEXP *rx = cbs->cb[n].src_regex;
- if (rx) {
- cbs->cb[n].src_regex = NULL;
- SvREFCNT_dec_NN(rx);
- }
- }
- Safefree(cbs->cb);
- Safefree(cbs);
-}
-
-
-static struct reg_code_blocks *
-S_alloc_code_blocks(pTHX_ int ncode)
-{
- struct reg_code_blocks *cbs;
- Newx(cbs, 1, struct reg_code_blocks);
- cbs->count = ncode;
- cbs->refcnt = 1;
- SAVEDESTRUCTOR_X(S_free_codeblocks, cbs);
- if (ncode)
- Newx(cbs->cb, ncode, struct reg_code_block);
- else
- cbs->cb = NULL;
- return cbs;
-}
-
-
-/* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
- * blocks, recalculate the indices. Update pat_p and plen_p in-place to
- * point to the realloced string and length.
- *
- * This is essentially a copy of Perl_bytes_to_utf8() with the code index
- * stuff added */
-
-static void
-S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
- char **pat_p, STRLEN *plen_p, int num_code_blocks)
-{
- U8 *const src = (U8*)*pat_p;
- U8 *dst, *d;
- int n=0;
- STRLEN s = 0;
- bool do_end = 0;
- DECLARE_AND_GET_RE_DEBUG_FLAGS;
-
- DEBUG_PARSE_r(Perl_re_printf( aTHX_
- "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
-
- /* 1 for each byte + 1 for each byte that expands to two, + trailing NUL */
- Newx(dst, *plen_p + variant_under_utf8_count(src, src + *plen_p) + 1, U8);
- d = dst;
-
- while (s < *plen_p) {
- append_utf8_from_native_byte(src[s], &d);
-
- if (n < num_code_blocks) {
- assert(pRExC_state->code_blocks);
- if (!do_end && pRExC_state->code_blocks->cb[n].start == s) {
- pRExC_state->code_blocks->cb[n].start = d - dst - 1;
- assert(*(d - 1) == '(');
- do_end = 1;
- }
- else if (do_end && pRExC_state->code_blocks->cb[n].end == s) {
- pRExC_state->code_blocks->cb[n].end = d - dst - 1;
- assert(*(d - 1) == ')');
- do_end = 0;
- n++;
- }
- }
- s++;
- }
- *d = '\0';
- *plen_p = d - dst;
- *pat_p = (char*) dst;
- SAVEFREEPV(*pat_p);
- RExC_orig_utf8 = RExC_utf8 = 1;
-}
-
-
-
-/* S_concat_pat(): concatenate a list of args to the pattern string pat,
- * while recording any code block indices, and handling overloading,
- * nested qr// objects etc. If pat is null, it will allocate a new
- * string, or just return the first arg, if there's only one.
- *
- * Returns the malloced/updated pat.
- * patternp and pat_count is the array of SVs to be concatted;
- * oplist is the optional list of ops that generated the SVs;
- * recompile_p is a pointer to a boolean that will be set if
- * the regex will need to be recompiled.
- * delim, if non-null is an SV that will be inserted between each element
- */
-
-static SV*
-S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
- SV *pat, SV ** const patternp, int pat_count,
- OP *oplist, bool *recompile_p, SV *delim)
-{
- SV **svp;
- int n = 0;
- bool use_delim = FALSE;
- bool alloced = FALSE;
-
- /* if we know we have at least two args, create an empty string,
- * then concatenate args to that. For no args, return an empty string */
- if (!pat && pat_count != 1) {
- pat = newSVpvs("");
- SAVEFREESV(pat);
- alloced = TRUE;
- }
-
- for (svp = patternp; svp < patternp + pat_count; svp++) {
- SV *sv;
- SV *rx = NULL;
- STRLEN orig_patlen = 0;
- bool code = 0;
- SV *msv = use_delim ? delim : *svp;
- if (!msv) msv = &PL_sv_undef;
-
- /* if we've got a delimiter, we go round the loop twice for each
- * svp slot (except the last), using the delimiter the second
- * time round */
- if (use_delim) {
- svp--;
- use_delim = FALSE;
- }
- else if (delim)
- use_delim = TRUE;
-
- if (SvTYPE(msv) == SVt_PVAV) {
- /* we've encountered an interpolated array within
- * the pattern, e.g. /...@a..../. Expand the list of elements,
- * then recursively append elements.
- * The code in this block is based on S_pushav() */
-
- AV *const av = (AV*)msv;
- const SSize_t maxarg = AvFILL(av) + 1;
- SV **array;
-
- if (oplist) {
- assert(oplist->op_type == OP_PADAV
- || oplist->op_type == OP_RV2AV);
- oplist = OpSIBLING(oplist);
- }
-
- if (SvRMAGICAL(av)) {
- SSize_t i;
-
- Newx(array, maxarg, SV*);
- SAVEFREEPV(array);
- for (i=0; i < maxarg; i++) {
- SV ** const svp = av_fetch(av, i, FALSE);
- array[i] = svp ? *svp : &PL_sv_undef;
- }
- }
- else
- array = AvARRAY(av);
-
- pat = S_concat_pat(aTHX_ pRExC_state, pat,
- array, maxarg, NULL, recompile_p,
- /* $" */
- GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV))));
-
- continue;
- }
-
-
- /* we make the assumption here that each op in the list of
- * op_siblings maps to one SV pushed onto the stack,
- * except for code blocks, with have both an OP_NULL and
- * an OP_CONST.
- * This allows us to match up the list of SVs against the
- * list of OPs to find the next code block.
- *
- * Note that PUSHMARK PADSV PADSV ..
- * is optimised to
- * PADRANGE PADSV PADSV ..
- * so the alignment still works. */
-
- if (oplist) {
- if (oplist->op_type == OP_NULL
- && (oplist->op_flags & OPf_SPECIAL))
- {
- assert(n < pRExC_state->code_blocks->count);
- pRExC_state->code_blocks->cb[n].start = pat ? SvCUR(pat) : 0;
- pRExC_state->code_blocks->cb[n].block = oplist;
- pRExC_state->code_blocks->cb[n].src_regex = NULL;
- n++;
- code = 1;
- oplist = OpSIBLING(oplist); /* skip CONST */
- assert(oplist);
- }
- oplist = OpSIBLING(oplist);;
- }
-
- /* apply magic and QR overloading to arg */
-
- SvGETMAGIC(msv);
- if (SvROK(msv) && SvAMAGIC(msv)) {
- SV *sv = AMG_CALLunary(msv, regexp_amg);
- if (sv) {
- if (SvROK(sv))
- sv = SvRV(sv);
- if (SvTYPE(sv) != SVt_REGEXP)
- Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
- msv = sv;
- }
- }
-
- /* try concatenation overload ... */
- if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
- (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
- {
- sv_setsv(pat, sv);
- /* overloading involved: all bets are off over literal
- * code. Pretend we haven't seen it */
- if (n)
- pRExC_state->code_blocks->count -= n;
- n = 0;
- }
- else {
- /* ... or failing that, try "" overload */
- while (SvAMAGIC(msv)
- && (sv = AMG_CALLunary(msv, string_amg))
- && sv != msv
- && !( SvROK(msv)
- && SvROK(sv)
- && SvRV(msv) == SvRV(sv))
- ) {
- msv = sv;
- SvGETMAGIC(msv);
- }
- if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
- msv = SvRV(msv);
-
- if (pat) {
- /* this is a partially unrolled
- * sv_catsv_nomg(pat, msv);
- * that allows us to adjust code block indices if
- * needed */
- STRLEN dlen;
- char *dst = SvPV_force_nomg(pat, dlen);
- orig_patlen = dlen;
- if (SvUTF8(msv) && !SvUTF8(pat)) {
- S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n);
- sv_setpvn(pat, dst, dlen);
- SvUTF8_on(pat);
- }
- sv_catsv_nomg(pat, msv);
- rx = msv;
- }
- else {
- /* We have only one SV to process, but we need to verify
- * it is properly null terminated or we will fail asserts
- * later. In theory we probably shouldn't get such SV's,
- * but if we do we should handle it gracefully. */
- if ( SvTYPE(msv) != SVt_PV || (SvLEN(msv) > SvCUR(msv) && *(SvEND(msv)) == 0) || SvIsCOW_shared_hash(msv) ) {
- /* not a string, or a string with a trailing null */
- pat = msv;
- } else {
- /* a string with no trailing null, we need to copy it
- * so it has a trailing null */
- pat = sv_2mortal(newSVsv(msv));
- }
- }
-
- if (code)
- pRExC_state->code_blocks->cb[n-1].end = SvCUR(pat)-1;
- }
-
- /* extract any code blocks within any embedded qr//'s */
- if (rx && SvTYPE(rx) == SVt_REGEXP
- && RX_ENGINE((REGEXP*)rx)->op_comp)
- {
-
- RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
- if (ri->code_blocks && ri->code_blocks->count) {
- int i;
- /* the presence of an embedded qr// with code means
- * we should always recompile: the text of the
- * qr// may not have changed, but it may be a
- * different closure than last time */
- *recompile_p = 1;
- if (pRExC_state->code_blocks) {
- int new_count = pRExC_state->code_blocks->count
- + ri->code_blocks->count;
- Renew(pRExC_state->code_blocks->cb,
- new_count, struct reg_code_block);
- pRExC_state->code_blocks->count = new_count;
- }
- else
- pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_
- ri->code_blocks->count);
-
- for (i=0; i < ri->code_blocks->count; i++) {
- struct reg_code_block *src, *dst;
- STRLEN offset = orig_patlen
- + ReANY((REGEXP *)rx)->pre_prefix;
- assert(n < pRExC_state->code_blocks->count);
- src = &ri->code_blocks->cb[i];
- dst = &pRExC_state->code_blocks->cb[n];
- dst->start = src->start + offset;
- dst->end = src->end + offset;
- dst->block = src->block;
- dst->src_regex = (REGEXP*) SvREFCNT_inc( (SV*)
- src->src_regex
- ? src->src_regex
- : (REGEXP*)rx);
- n++;
- }
- }
- }
- }
- /* avoid calling magic multiple times on a single element e.g. =~ $qr */
- if (alloced)
- SvSETMAGIC(pat);
-
- return pat;
-}
-
-
-
-/* see if there are any run-time code blocks in the pattern.
- * False positives are allowed */
-
-static bool
-S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
- char *pat, STRLEN plen)
-{
- int n = 0;
- STRLEN s;
-
- PERL_UNUSED_CONTEXT;
-
- for (s = 0; s < plen; s++) {
- if ( pRExC_state->code_blocks
- && n < pRExC_state->code_blocks->count
- && s == pRExC_state->code_blocks->cb[n].start)
- {
- s = pRExC_state->code_blocks->cb[n].end;
- n++;
- continue;
- }
- /* TODO ideally should handle [..], (#..), /#.../x to reduce false
- * positives here */
- if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
- (pat[s+2] == '{'
- || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
- )
- return 1;
- }
- return 0;
-}
-
-/* Handle run-time code blocks. We will already have compiled any direct
- * or indirect literal code blocks. Now, take the pattern 'pat' and make a
- * copy of it, but with any literal code blocks blanked out and
- * appropriate chars escaped; then feed it into
- *
- * eval "qr'modified_pattern'"
- *
- * For example,
- *
- * a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
- *
- * becomes
- *
- * qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
- *
- * After eval_sv()-ing that, grab any new code blocks from the returned qr
- * and merge them with any code blocks of the original regexp.
- *
- * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
- * instead, just save the qr and return FALSE; this tells our caller that
- * the original pattern needs upgrading to utf8.
- */
-
-static bool
-S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
- char *pat, STRLEN plen)
-{
- SV *qr;
-
- DECLARE_AND_GET_RE_DEBUG_FLAGS;
-
- if (pRExC_state->runtime_code_qr) {
- /* this is the second time we've been called; this should
- * only happen if the main pattern got upgraded to utf8
- * during compilation; re-use the qr we compiled first time
- * round (which should be utf8 too)
- */
- qr = pRExC_state->runtime_code_qr;
- pRExC_state->runtime_code_qr = NULL;
- assert(RExC_utf8 && SvUTF8(qr));
- }
- else {
- int n = 0;
- STRLEN s;
- char *p, *newpat;
- int newlen = plen + 7; /* allow for "qr''xx\0" extra chars */
- SV *sv, *qr_ref;
- dSP;
-
- /* determine how many extra chars we need for ' and \ escaping */
- for (s = 0; s < plen; s++) {
- if (pat[s] == '\'' || pat[s] == '\\')
- newlen++;
- }
-
- Newx(newpat, newlen, char);
- p = newpat;
- *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
-
- for (s = 0; s < plen; s++) {
- if ( pRExC_state->code_blocks
- && n < pRExC_state->code_blocks->count
- && s == pRExC_state->code_blocks->cb[n].start)
- {
- /* blank out literal code block so that they aren't
- * recompiled: eg change from/to:
- * /(?{xyz})/
- * /(?=====)/
- * and
- * /(??{xyz})/
- * /(?======)/
- * and
- * /(?(?{xyz}))/
- * /(?(?=====))/
- */
- assert(pat[s] == '(');
- assert(pat[s+1] == '?');
- *p++ = '(';
- *p++ = '?';
- s += 2;
- while (s < pRExC_state->code_blocks->cb[n].end) {
- *p++ = '=';
- s++;
- }
- *p++ = ')';
- n++;
- continue;
- }
- if (pat[s] == '\'' || pat[s] == '\\')
- *p++ = '\\';
- *p++ = pat[s];
- }
- *p++ = '\'';
- if (pRExC_state->pm_flags & RXf_PMf_EXTENDED) {
- *p++ = 'x';
- if (pRExC_state->pm_flags & RXf_PMf_EXTENDED_MORE) {
- *p++ = 'x';
- }
- }
- *p++ = '\0';
- DEBUG_COMPILE_r({
- Perl_re_printf( aTHX_
- "%sre-parsing pattern for runtime code:%s %s\n",
- PL_colors[4], PL_colors[5], newpat);
- });
-
- sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
- Safefree(newpat);
-
- ENTER;
- SAVETMPS;
- save_re_context();
- PUSHSTACKi(PERLSI_REQUIRE);
- /* G_RE_REPARSING causes the toker to collapse \\ into \ when
- * parsing qr''; normally only q'' does this. It also alters
- * hints handling */
- eval_sv(sv, G_SCALAR|G_RE_REPARSING);
- SvREFCNT_dec_NN(sv);
- SPAGAIN;
- qr_ref = POPs;
- PUTBACK;
- {
- SV * const errsv = ERRSV;
- if (SvTRUE_NN(errsv))
- /* use croak_sv ? */
- Perl_croak_nocontext("%" SVf, SVfARG(errsv));
- }
- assert(SvROK(qr_ref));
- qr = SvRV(qr_ref);
- assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
- /* the leaving below frees the tmp qr_ref.
- * Give qr a life of its own */
- SvREFCNT_inc(qr);
- POPSTACK;
- FREETMPS;
- LEAVE;
-
- }
-
- if (!RExC_utf8 && SvUTF8(qr)) {
- /* first time through; the pattern got upgraded; save the
- * qr for the next time through */
- assert(!pRExC_state->runtime_code_qr);
- pRExC_state->runtime_code_qr = qr;
- return 0;
- }
-
-
- /* extract any code blocks within the returned qr// */
-
-
- /* merge the main (r1) and run-time (r2) code blocks into one */
- {
- RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
- struct reg_code_block *new_block, *dst;
- RExC_state_t * const r1 = pRExC_state; /* convenient alias */
- int i1 = 0, i2 = 0;
- int r1c, r2c;
-
- if (!r2->code_blocks || !r2->code_blocks->count) /* we guessed wrong */
- {
- SvREFCNT_dec_NN(qr);
- return 1;
- }
-
- if (!r1->code_blocks)
- r1->code_blocks = S_alloc_code_blocks(aTHX_ 0);
-
- r1c = r1->code_blocks->count;
- r2c = r2->code_blocks->count;
-
- Newx(new_block, r1c + r2c, struct reg_code_block);
-
- dst = new_block;
-
- while (i1 < r1c || i2 < r2c) {
- struct reg_code_block *src;
- bool is_qr = 0;
-
- if (i1 == r1c) {
- src = &r2->code_blocks->cb[i2++];
- is_qr = 1;
- }
- else if (i2 == r2c)
- src = &r1->code_blocks->cb[i1++];
- else if ( r1->code_blocks->cb[i1].start
- < r2->code_blocks->cb[i2].start)
- {
- src = &r1->code_blocks->cb[i1++];
- assert(src->end < r2->code_blocks->cb[i2].start);
- }
- else {
- assert( r1->code_blocks->cb[i1].start
- > r2->code_blocks->cb[i2].start);
- src = &r2->code_blocks->cb[i2++];
- is_qr = 1;
- assert(src->end < r1->code_blocks->cb[i1].start);
- }
-
- assert(pat[src->start] == '(');
- assert(pat[src->end] == ')');
- dst->start = src->start;
- dst->end = src->end;
- dst->block = src->block;
- dst->src_regex = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
- : src->src_regex;
- dst++;
- }
- r1->code_blocks->count += r2c;
- Safefree(r1->code_blocks->cb);
- r1->code_blocks->cb = new_block;
- }
-
- SvREFCNT_dec_NN(qr);
- return 1;
-}
-
-
-STATIC bool
-S_setup_longest(pTHX_ RExC_state_t *pRExC_state,
- struct reg_substr_datum *rsd,
- struct scan_data_substrs *sub,
- STRLEN longest_length)
-{
- /* This is the common code for setting up the floating and fixed length
- * string data extracted from Perl_re_op_compile() below. Returns a boolean
- * as to whether succeeded or not */
-
- I32 t;
- SSize_t ml;
- bool eol = cBOOL(sub->flags & SF_BEFORE_EOL);
- bool meol = cBOOL(sub->flags & SF_BEFORE_MEOL);
-
- if (! (longest_length
- || (eol /* Can't have SEOL and MULTI */
- && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
- )
- /* See comments for join_exact for why REG_UNFOLDED_MULTI_SEEN */
- || (RExC_seen & REG_UNFOLDED_MULTI_SEEN))
- {
- return FALSE;
- }
-
- /* copy the information about the longest from the reg_scan_data
- over to the program. */
- if (SvUTF8(sub->str)) {
- rsd->substr = NULL;
- rsd->utf8_substr = sub->str;
- } else {
- rsd->substr = sub->str;
- rsd->utf8_substr = NULL;
- }
- /* end_shift is how many chars that must be matched that
- follow this item. We calculate it ahead of time as once the
- lookbehind offset is added in we lose the ability to correctly
- calculate it.*/
- ml = sub->minlenp ? *(sub->minlenp) : (SSize_t)longest_length;
- rsd->end_shift = ml - sub->min_offset
- - longest_length
- /* XXX SvTAIL is always false here - did you mean FBMcf_TAIL
- * intead? - DAPM
- + (SvTAIL(sub->str) != 0)
- */
- + sub->lookbehind;
-
- t = (eol/* Can't have SEOL and MULTI */
- && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
- fbm_compile(sub->str, t ? FBMcf_TAIL : 0);
-
- return TRUE;
-}
-
-STATIC void
-S_set_regex_pv(pTHX_ RExC_state_t *pRExC_state, REGEXP *Rx)
-{
- /* Calculates and sets in the compiled pattern 'Rx' the string to compile,
- * properly wrapped with the right modifiers */
-
- bool has_p = ((RExC_rx->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
- bool has_charset = RExC_utf8 || (get_regex_charset(RExC_rx->extflags)
- != REGEX_DEPENDS_CHARSET);
-
- /* The caret is output if there are any defaults: if not all the STD
- * flags are set, or if no character set specifier is needed */
- bool has_default =
- (((RExC_rx->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
- || ! has_charset);
- bool has_runon = ((RExC_seen & REG_RUN_ON_COMMENT_SEEN)
- == REG_RUN_ON_COMMENT_SEEN);
- U8 reganch = (U8)((RExC_rx->extflags & RXf_PMf_STD_PMMOD)
- >> RXf_PMf_STD_PMMOD_SHIFT);
- const char *fptr = STD_PAT_MODS; /*"msixxn"*/
- char *p;
- STRLEN pat_len = RExC_precomp_end - RExC_precomp;
-
- /* We output all the necessary flags; we never output a minus, as all
- * those are defaults, so are
- * covered by the caret */
- const STRLEN wraplen = pat_len + has_p + has_runon
- + has_default /* If needs a caret */
- + PL_bitcount[reganch] /* 1 char for each set standard flag */
-
- /* If needs a character set specifier */
- + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
- + (sizeof("(?:)") - 1);
-
- PERL_ARGS_ASSERT_SET_REGEX_PV;
-
- /* make sure PL_bitcount bounds not exceeded */
- STATIC_ASSERT_STMT(sizeof(STD_PAT_MODS) <= 8);
-
- p = sv_grow(MUTABLE_SV(Rx), wraplen + 1); /* +1 for the ending NUL */
- SvPOK_on(Rx);
- if (RExC_utf8)
- SvFLAGS(Rx) |= SVf_UTF8;
- *p++='('; *p++='?';
-
- /* If a default, cover it using the caret */
- if (has_default) {
- *p++= DEFAULT_PAT_MOD;
- }
- if (has_charset) {
- STRLEN len;
- const char* name;
-
- name = get_regex_charset_name(RExC_rx->extflags, &len);
- if (strEQ(name, DEPENDS_PAT_MODS)) { /* /d under UTF-8 => /u */
- assert(RExC_utf8);
- name = UNICODE_PAT_MODS;
- len = sizeof(UNICODE_PAT_MODS) - 1;
- }
- Copy(name, p, len, char);
- p += len;
- }
- if (has_p)
- *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
- {
- char ch;
- while((ch = *fptr++)) {
- if(reganch & 1)
- *p++ = ch;
- reganch >>= 1;
- }
- }
-
- *p++ = ':';
- Copy(RExC_precomp, p, pat_len, char);
- assert ((RX_WRAPPED(Rx) - p) < 16);
- RExC_rx->pre_prefix = p - RX_WRAPPED(Rx);
- p += pat_len;
-
- /* Adding a trailing \n causes this to compile properly:
- my $R = qr / A B C # D E/x; /($R)/
- Otherwise the parens are considered part of the comment */
- if (has_runon)
- *p++ = '\n';
- *p++ = ')';
- *p = 0;
- SvCUR_set(Rx, p - RX_WRAPPED(Rx));
-}
-
-/*
- * Perl_re_op_compile - the perl internal RE engine's function to compile a
- * regular expression into internal code.
- * The pattern may be passed either as:
- * a list of SVs (patternp plus pat_count)
- * a list of OPs (expr)
- * If both are passed, the SV list is used, but the OP list indicates
- * which SVs are actually pre-compiled code blocks
- *
- * The SVs in the list have magic and qr overloading applied to them (and
- * the list may be modified in-place with replacement SVs in the latter
- * case).
- *
- * If the pattern hasn't changed from old_re, then old_re will be
- * returned.
- *
- * eng is the current engine. If that engine has an op_comp method, then
- * handle directly (i.e. we assume that op_comp was us); otherwise, just
- * do the initial concatenation of arguments and pass on to the external
- * engine.
- *
- * If is_bare_re is not null, set it to a boolean indicating whether the
- * arg list reduced (after overloading) to a single bare regex which has
- * been returned (i.e. /$qr/).
- *
- * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
- *
- * pm_flags contains the PMf_* flags, typically based on those from the
- * pm_flags field of the related PMOP. Currently we're only interested in
- * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL, PMf_WILDCARD.
- *
- * For many years this code had an initial sizing pass that calculated
- * (sometimes incorrectly, leading to security holes) the size needed for the
- * compiled pattern. That was changed by commit
- * 7c932d07cab18751bfc7515b4320436273a459e2 in 5.29, which reallocs the size, a
- * node at a time, as parsing goes along. Patches welcome to fix any obsolete
- * references to this sizing pass.
- *
- * Now, an initial crude guess as to the size needed is made, based on the
- * length of the pattern. Patches welcome to improve that guess. That amount
- * of space is malloc'd and then immediately freed, and then clawed back node
- * by node. This design is to minimze, to the extent possible, memory churn
- * when doing the reallocs.
- *
- * A separate parentheses counting pass may be needed in some cases.
- * (Previously the sizing pass did this.) Patches welcome to reduce the number
- * of these cases.
- *
- * The existence of a sizing pass necessitated design decisions that are no
- * longer needed. There are potential areas of simplification.
- *
- * Beware that the optimization-preparation code in here knows about some
- * of the structure of the compiled regexp. [I'll say.]
- */
-
-REGEXP *
-Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
- OP *expr, const regexp_engine* eng, REGEXP *old_re,
- bool *is_bare_re, const U32 orig_rx_flags, const U32 pm_flags)
-{
- REGEXP *Rx; /* Capital 'R' means points to a REGEXP */
- STRLEN plen;
- char *exp;
- regnode *scan;
- I32 flags;
- SSize_t minlen = 0;
- U32 rx_flags;
- SV *pat;
- SV** new_patternp = patternp;
-
- /* these are all flags - maybe they should be turned
- * into a single int with different bit masks */
- I32 sawlookahead = 0;
- I32 sawplus = 0;
- I32 sawopen = 0;
- I32 sawminmod = 0;
-
- regex_charset initial_charset = get_regex_charset(orig_rx_flags);
- bool recompile = 0;
- bool runtime_code = 0;
- scan_data_t data;
- RExC_state_t RExC_state;
- RExC_state_t * const pRExC_state = &RExC_state;
-#ifdef TRIE_STUDY_OPT
- int restudied = 0;
- RExC_state_t copyRExC_state;
-#endif
- DECLARE_AND_GET_RE_DEBUG_FLAGS;
-
- PERL_ARGS_ASSERT_RE_OP_COMPILE;
-
- DEBUG_r(if (!PL_colorset) reginitcolors());
-
-
- pRExC_state->warn_text = NULL;
- pRExC_state->unlexed_names = NULL;
- pRExC_state->code_blocks = NULL;
-
- if (is_bare_re)
- *is_bare_re = FALSE;
-
- if (expr && (expr->op_type == OP_LIST ||
- (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
- /* allocate code_blocks if needed */
- OP *o;
- int ncode = 0;
-
- for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o))
- if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
- ncode++; /* count of DO blocks */
-
- if (ncode)
- pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_ ncode);
- }
-
- if (!pat_count) {
- /* compile-time pattern with just OP_CONSTs and DO blocks */
-
- int n;
- OP *o;
-
- /* find how many CONSTs there are */
- assert(expr);
- n = 0;
- if (expr->op_type == OP_CONST)
- n = 1;
- else
- for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
- if (o->op_type == OP_CONST)
- n++;
- }
-
- /* fake up an SV array */
-
- assert(!new_patternp);
- Newx(new_patternp, n, SV*);
- SAVEFREEPV(new_patternp);
- pat_count = n;
-
- n = 0;
- if (expr->op_type == OP_CONST)
- new_patternp[n] = cSVOPx_sv(expr);
- else
- for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
- if (o->op_type == OP_CONST)
- new_patternp[n++] = cSVOPo_sv;
- }
-
- }
-
- DEBUG_PARSE_r(Perl_re_printf( aTHX_
- "Assembling pattern from %d elements%s\n", pat_count,
- orig_rx_flags & RXf_SPLIT ? " for split" : ""));
-
- /* set expr to the first arg op */
-
- if (pRExC_state->code_blocks && pRExC_state->code_blocks->count
- && expr->op_type != OP_CONST)
- {
- expr = cLISTOPx(expr)->op_first;
- assert( expr->op_type == OP_PUSHMARK
- || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK)
- || expr->op_type == OP_PADRANGE);
- expr = OpSIBLING(expr);
- }
-
- pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count,
- expr, &recompile, NULL);
-
- /* handle bare (possibly after overloading) regex: foo =~ $re */
- {
- SV *re = pat;
- if (SvROK(re))
- re = SvRV(re);
- if (SvTYPE(re) == SVt_REGEXP) {
- if (is_bare_re)
- *is_bare_re = TRUE;
- SvREFCNT_inc(re);
- DEBUG_PARSE_r(Perl_re_printf( aTHX_
- "Precompiled pattern%s\n",
- orig_rx_flags & RXf_SPLIT ? " for split" : ""));
-
- return (REGEXP*)re;
- }
- }
-
- exp = SvPV_nomg(pat, plen);
-
- if (!eng->op_comp) {
- if ((SvUTF8(pat) && IN_BYTES)
- || SvGMAGICAL(pat) || SvAMAGIC(pat))
- {
- /* make a temporary copy; either to convert to bytes,
- * or to avoid repeating get-magic / overloaded stringify */
- pat = newSVpvn_flags(exp, plen, SVs_TEMP |
- (IN_BYTES ? 0 : SvUTF8(pat)));
- }
- return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
- }
-
- /* ignore the utf8ness if the pattern is 0 length */
- RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
- RExC_uni_semantics = 0;
- RExC_contains_locale = 0;
- RExC_strict = cBOOL(pm_flags & RXf_PMf_STRICT);
- RExC_in_script_run = 0;
- RExC_study_started = 0;
- pRExC_state->runtime_code_qr = NULL;
- RExC_frame_head= NULL;
- RExC_frame_last= NULL;
- RExC_frame_count= 0;
- RExC_latest_warn_offset = 0;
- RExC_use_BRANCHJ = 0;
- RExC_warned_WARN_EXPERIMENTAL__VLB = 0;
- RExC_warned_WARN_EXPERIMENTAL__REGEX_SETS = 0;
- RExC_total_parens = 0;
- RExC_open_parens = NULL;
- RExC_close_parens = NULL;
- RExC_paren_names = NULL;
- RExC_size = 0;
- RExC_seen_d_op = FALSE;
-#ifdef DEBUGGING
- RExC_paren_name_list = NULL;
-#endif
-
- DEBUG_r({
- RExC_mysv1= sv_newmortal();
- RExC_mysv2= sv_newmortal();
- });
-
- DEBUG_COMPILE_r({
- SV *dsv= sv_newmortal();
- RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, PL_dump_re_max_len);
- Perl_re_printf( aTHX_ "%sCompiling REx%s %s\n",
- PL_colors[4], PL_colors[5], s);
- });
-
- /* we jump here if we have to recompile, e.g., from upgrading the pattern
- * to utf8 */
-
- if ((pm_flags & PMf_USE_RE_EVAL)
- /* this second condition covers the non-regex literal case,
- * i.e. $foo =~ '(?{})'. */
- || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
- )
- runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
-
- redo_parse:
- /* return old regex if pattern hasn't changed */
- /* XXX: note in the below we have to check the flags as well as the
- * pattern.
- *
- * Things get a touch tricky as we have to compare the utf8 flag
- * independently from the compile flags. */
-
- if ( old_re
- && !recompile
- && !!RX_UTF8(old_re) == !!RExC_utf8
- && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
- && RX_PRECOMP(old_re)
- && RX_PRELEN(old_re) == plen
- && memEQ(RX_PRECOMP(old_re), exp, plen)
- && !runtime_code /* with runtime code, always recompile */ )
- {
- DEBUG_COMPILE_r({
- SV *dsv= sv_newmortal();
- RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, PL_dump_re_max_len);
- Perl_re_printf( aTHX_ "%sSkipping recompilation of unchanged REx%s %s\n",
- PL_colors[4], PL_colors[5], s);
- });
- return old_re;
- }
-
- /* Allocate the pattern's SV */
- RExC_rx_sv = Rx = (REGEXP*) newSV_type(SVt_REGEXP);
- RExC_rx = ReANY(Rx);
- if ( RExC_rx == NULL )
- FAIL("Regexp out of space");
-
- rx_flags = orig_rx_flags;
-
- if ( toUSE_UNI_CHARSET_NOT_DEPENDS
- && initial_charset == REGEX_DEPENDS_CHARSET)
- {
-
- /* Set to use unicode semantics if the pattern is in utf8 and has the
- * 'depends' charset specified, as it means unicode when utf8 */
- set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
- RExC_uni_semantics = 1;
- }
-
- RExC_pm_flags = pm_flags;
-
- if (runtime_code) {
- assert(TAINTING_get || !TAINT_get);
- if (TAINT_get)
- Perl_croak(aTHX_ "Eval-group in insecure regular expression");
-
- if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
- /* whoops, we have a non-utf8 pattern, whilst run-time code
- * got compiled as utf8. Try again with a utf8 pattern */
- S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
- pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
- goto redo_parse;
- }
- }
- assert(!pRExC_state->runtime_code_qr);
-
- RExC_sawback = 0;
-
- RExC_seen = 0;
- RExC_maxlen = 0;
- RExC_in_lookaround = 0;
- RExC_seen_zerolen = *exp == '^' ? -1 : 0;
- RExC_recode_x_to_native = 0;
- RExC_in_multi_char_class = 0;
-
- RExC_start = RExC_copy_start_in_constructed = RExC_copy_start_in_input = RExC_precomp = exp;
- RExC_precomp_end = RExC_end = exp + plen;
- RExC_nestroot = 0;
- RExC_whilem_seen = 0;
- RExC_end_op = NULL;
- RExC_recurse = NULL;
- RExC_study_chunk_recursed = NULL;
- RExC_study_chunk_recursed_bytes= 0;
- RExC_recurse_count = 0;
- RExC_sets_depth = 0;
- pRExC_state->code_index = 0;
-
- /* Initialize the string in the compiled pattern. This is so that there is
- * something to output if necessary */
- set_regex_pv(pRExC_state, Rx);
-
- DEBUG_PARSE_r({
- Perl_re_printf( aTHX_
- "Starting parse and generation\n");
- RExC_lastnum=0;
- RExC_lastparse=NULL;
- });
-
- /* Allocate space and zero-initialize. Note, the two step process
- of zeroing when in debug mode, thus anything assigned has to
- happen after that */
- if (! RExC_size) {
-
- /* On the first pass of the parse, we guess how big this will be. Then
- * we grow in one operation to that amount and then give it back. As
- * we go along, we re-allocate what we need.
- *
- * XXX Currently the guess is essentially that the pattern will be an
- * EXACT node with one byte input, one byte output. This is crude, and
- * better heuristics are welcome.
- *
- * On any subsequent passes, we guess what we actually computed in the
- * latest earlier pass. Such a pass probably didn't complete so is
- * missing stuff. We could improve those guesses by knowing where the
- * parse stopped, and use the length so far plus apply the above
- * assumption to what's left. */
- RExC_size = STR_SZ(RExC_end - RExC_start);
- }
-
- Newxc(RExC_rxi, sizeof(regexp_internal) + RExC_size, char, regexp_internal);
- if ( RExC_rxi == NULL )
- FAIL("Regexp out of space");
-
- Zero(RExC_rxi, sizeof(regexp_internal) + RExC_size, char);
- RXi_SET( RExC_rx, RExC_rxi );
-
- /* We start from 0 (over from 0 in the case this is a reparse. The first
- * node parsed will give back any excess memory we have allocated so far).
- * */
- RExC_size = 0;
-
- /* non-zero initialization begins here */
- RExC_rx->engine= eng;
- RExC_rx->extflags = rx_flags;
- RXp_COMPFLAGS(RExC_rx) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
-
- if (pm_flags & PMf_IS_QR) {
- RExC_rxi->code_blocks = pRExC_state->code_blocks;
- if (RExC_rxi->code_blocks) {
- RExC_rxi->code_blocks->refcnt++;
- }
- }
-
- RExC_rx->intflags = 0;
-
- RExC_flags = rx_flags; /* don't let top level (?i) bleed */
- RExC_parse = exp;
-
- /* This NUL is guaranteed because the pattern comes from an SV*, and the sv
- * code makes sure the final byte is an uncounted NUL. But should this
- * ever not be the case, lots of things could read beyond the end of the
- * buffer: loops like
- * while(isFOO(*RExC_parse)) RExC_parse++;
- * strchr(RExC_parse, "foo");
- * etc. So it is worth noting. */
- assert(*RExC_end == '\0');
-
- RExC_naughty = 0;
- RExC_npar = 1;
- RExC_parens_buf_size = 0;
- RExC_emit_start = RExC_rxi->program;
- pRExC_state->code_index = 0;
-
- *((char*) RExC_emit_start) = (char) REG_MAGIC;
- RExC_emit = 1;
-
- /* Do the parse */
- if (reg(pRExC_state, 0, &flags, 1)) {
-
- /* Success!, But we may need to redo the parse knowing how many parens
- * there actually are */
- if (IN_PARENS_PASS) {
- flags |= RESTART_PARSE;
- }
-
- /* We have that number in RExC_npar */
- RExC_total_parens = RExC_npar;
- }
- else if (! MUST_RESTART(flags)) {
- ReREFCNT_dec(Rx);
- Perl_croak(aTHX_ "panic: reg returned failure to re_op_compile, flags=%#" UVxf, (UV) flags);
- }
-
- /* Here, we either have success, or we have to redo the parse for some reason */
- if (MUST_RESTART(flags)) {
-
- /* It's possible to write a regexp in ascii that represents Unicode
- codepoints outside of the byte range, such as via \x{100}. If we
- detect such a sequence we have to convert the entire pattern to utf8
- and then recompile, as our sizing calculation will have been based
- on 1 byte == 1 character, but we will need to use utf8 to encode
- at least some part of the pattern, and therefore must convert the whole
- thing.
- -- dmq */
- if (flags & NEED_UTF8) {
-
- /* We have stored the offset of the final warning output so far.
- * That must be adjusted. Any variant characters between the start
- * of the pattern and this warning count for 2 bytes in the final,
- * so just add them again */
- if (UNLIKELY(RExC_latest_warn_offset > 0)) {
- RExC_latest_warn_offset +=
- variant_under_utf8_count((U8 *) exp, (U8 *) exp
- + RExC_latest_warn_offset);
- }
- S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
- pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
- DEBUG_PARSE_r(Perl_re_printf( aTHX_ "Need to redo parse after upgrade\n"));
- }
- else {
- DEBUG_PARSE_r(Perl_re_printf( aTHX_ "Need to redo parse\n"));
- }
-
- if (ALL_PARENS_COUNTED) {
- /* Make enough room for all the known parens, and zero it */
- Renew(RExC_open_parens, RExC_total_parens, regnode_offset);
- Zero(RExC_open_parens, RExC_total_parens, regnode_offset);
- RExC_open_parens[0] = 1; /* +1 for REG_MAGIC */
-
- Renew(RExC_close_parens, RExC_total_parens, regnode_offset);
- Zero(RExC_close_parens, RExC_total_parens, regnode_offset);
- }
- else { /* Parse did not complete. Reinitialize the parentheses
- structures */
- RExC_total_parens = 0;
- if (RExC_open_parens) {
- Safefree(RExC_open_parens);
- RExC_open_parens = NULL;
- }
- if (RExC_close_parens) {
- Safefree(RExC_close_parens);
- RExC_close_parens = NULL;
- }
- }
-
- /* Clean up what we did in this parse */
- SvREFCNT_dec_NN(RExC_rx_sv);
-
- goto redo_parse;
- }
-
- /* Here, we have successfully parsed and generated the pattern's program
- * for the regex engine. We are ready to finish things up and look for
- * optimizations. */
-
- /* Update the string to compile, with correct modifiers, etc */
- set_regex_pv(pRExC_state, Rx);
-
- RExC_rx->nparens = RExC_total_parens - 1;
-
- /* Uses the upper 4 bits of the FLAGS field, so keep within that size */
- if (RExC_whilem_seen > 15)
- RExC_whilem_seen = 15;
-
- DEBUG_PARSE_r({
- Perl_re_printf( aTHX_
- "Required size %" IVdf " nodes\n", (IV)RExC_size);
- RExC_lastnum=0;
- RExC_lastparse=NULL;
- });
-
-#ifdef RE_TRACK_PATTERN_OFFSETS
- DEBUG_OFFSETS_r(Perl_re_printf( aTHX_
- "%s %" UVuf " bytes for offset annotations.\n",
- RExC_offsets ? "Got" : "Couldn't get",
- (UV)((RExC_offsets[0] * 2 + 1))));
- DEBUG_OFFSETS_r(if (RExC_offsets) {
- const STRLEN len = RExC_offsets[0];
- STRLEN i;
- DECLARE_AND_GET_RE_DEBUG_FLAGS;
- Perl_re_printf( aTHX_
- "Offsets: [%" UVuf "]\n\t", (UV)RExC_offsets[0]);
- for (i = 1; i <= len; i++) {
- if (RExC_offsets[i*2-1] || RExC_offsets[i*2])
- Perl_re_printf( aTHX_ "%" UVuf ":%" UVuf "[%" UVuf "] ",
- (UV)i, (UV)RExC_offsets[i*2-1], (UV)RExC_offsets[i*2]);
- }
- Perl_re_printf( aTHX_ "\n");
- });
-
-#else
- SetProgLen(RExC_rxi,RExC_size);
-#endif
-
- DEBUG_DUMP_PRE_OPTIMIZE_r({
- SV * const sv = sv_newmortal();
- RXi_GET_DECL(RExC_rx, ri);
- DEBUG_RExC_seen();
- Perl_re_printf( aTHX_ "Program before optimization:\n");
-
- (void)dumpuntil(RExC_rx, ri->program, ri->program + 1, NULL, NULL,
- sv, 0, 0);
- });
-
- DEBUG_OPTIMISE_r(
- Perl_re_printf( aTHX_ "Starting post parse optimization\n");
- );
-
- /* XXXX To minimize changes to RE engine we always allocate
- 3-units-long substrs field. */
- Newx(RExC_rx->substrs, 1, struct reg_substr_data);
- if (RExC_recurse_count) {
- Newx(RExC_recurse, RExC_recurse_count, regnode *);
- SAVEFREEPV(RExC_recurse);
- }
-
- if (RExC_seen & REG_RECURSE_SEEN) {
- /* Note, RExC_total_parens is 1 + the number of parens in a pattern.
- * So its 1 if there are no parens. */
- RExC_study_chunk_recursed_bytes= (RExC_total_parens >> 3) +
- ((RExC_total_parens & 0x07) != 0);
- Newx(RExC_study_chunk_recursed,
- RExC_study_chunk_recursed_bytes * RExC_total_parens, U8);
- SAVEFREEPV(RExC_study_chunk_recursed);
- }
-
- reStudy:
- RExC_rx->minlen = minlen = sawlookahead = sawplus = sawopen = sawminmod = 0;
- DEBUG_r(
- RExC_study_chunk_recursed_count= 0;
- );
- Zero(RExC_rx->substrs, 1, struct reg_substr_data);
- if (RExC_study_chunk_recursed) {
- Zero(RExC_study_chunk_recursed,
- RExC_study_chunk_recursed_bytes * RExC_total_parens, U8);
- }
-
-
-#ifdef TRIE_STUDY_OPT
- if (!restudied) {
- StructCopy(&zero_scan_data, &data, scan_data_t);
- copyRExC_state = RExC_state;
- } else {
- U32 seen=RExC_seen;
- DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "Restudying\n"));
-
- RExC_state = copyRExC_state;
- if (seen & REG_TOP_LEVEL_BRANCHES_SEEN)
- RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
- else
- RExC_seen &= ~REG_TOP_LEVEL_BRANCHES_SEEN;
- StructCopy(&zero_scan_data, &data, scan_data_t);
- }
-#else
- StructCopy(&zero_scan_data, &data, scan_data_t);
-#endif
-
- /* Dig out information for optimizations. */
- RExC_rx->extflags = RExC_flags; /* was pm_op */
- /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
-
- if (UTF)
- SvUTF8_on(Rx); /* Unicode in it? */
- RExC_rxi->regstclass = NULL;
- if (RExC_naughty >= TOO_NAUGHTY) /* Probably an expensive pattern. */
- RExC_rx->intflags |= PREGf_NAUGHTY;
- scan = RExC_rxi->program + 1; /* First BRANCH. */
-
- /* testing for BRANCH here tells us whether there is "must appear"
- data in the pattern. If there is then we can use it for optimisations */
- if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)) { /* Only one top-level choice.
- */
- SSize_t fake;
- STRLEN longest_length[2];
- regnode_ssc ch_class; /* pointed to by data */
- int stclass_flag;
- SSize_t last_close = 0; /* pointed to by data */
- regnode *first= scan;
- regnode *first_next= regnext(first);
- int i;
-
- /*
- * Skip introductions and multiplicators >= 1
- * so that we can extract the 'meat' of the pattern that must
- * match in the large if() sequence following.
- * NOTE that EXACT is NOT covered here, as it is normally
- * picked up by the optimiser separately.
- *
- * This is unfortunate as the optimiser isnt handling lookahead
- * properly currently.
- *
- */
- while ((OP(first) == OPEN && (sawopen = 1)) ||
- /* An OR of *one* alternative - should not happen now. */
- (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
- /* for now we can't handle lookbehind IFMATCH*/
- (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
- (OP(first) == PLUS) ||
- (OP(first) == MINMOD) ||
- /* An {n,m} with n>0 */
- (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
- (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
- {
- /*
- * the only op that could be a regnode is PLUS, all the rest
- * will be regnode_1 or regnode_2.
- *
- * (yves doesn't think this is true)
- */
- if (OP(first) == PLUS)
- sawplus = 1;
- else {
- if (OP(first) == MINMOD)
- sawminmod = 1;
- first += regarglen[OP(first)];
- }
- first = NEXTOPER(first);
- first_next= regnext(first);
- }
-
- /* Starting-point info. */
- again:
- DEBUG_PEEP("first:", first, 0, 0);
- /* Ignore EXACT as we deal with it later. */
- if (PL_regkind[OP(first)] == EXACT) {
- if (! isEXACTFish(OP(first))) {
- NOOP; /* Empty, get anchored substr later. */
- }
- else
- RExC_rxi->regstclass = first;
- }
-#ifdef TRIE_STCLASS
- else if (PL_regkind[OP(first)] == TRIE &&
- ((reg_trie_data *)RExC_rxi->data->data[ ARG(first) ])->minlen>0)
- {
- /* this can happen only on restudy */
- RExC_rxi->regstclass = construct_ahocorasick_from_trie(pRExC_state, (regnode *)first, 0);
- }
-#endif
- else if (REGNODE_SIMPLE(OP(first)))
- RExC_rxi->regstclass = first;
- else if (PL_regkind[OP(first)] == BOUND ||
- PL_regkind[OP(first)] == NBOUND)
- RExC_rxi->regstclass = first;
- else if (PL_regkind[OP(first)] == BOL) {
- RExC_rx->intflags |= (OP(first) == MBOL
- ? PREGf_ANCH_MBOL
- : PREGf_ANCH_SBOL);
- first = NEXTOPER(first);
- goto again;
- }
- else if (OP(first) == GPOS) {
- RExC_rx->intflags |= PREGf_ANCH_GPOS;
- first = NEXTOPER(first);
- goto again;
- }
- else if ((!sawopen || !RExC_sawback) &&
- !sawlookahead &&
- (OP(first) == STAR &&
- PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
- !(RExC_rx->intflags & PREGf_ANCH) && !pRExC_state->code_blocks)
- {
- /* turn .* into ^.* with an implied $*=1 */
- const int type =
- (OP(NEXTOPER(first)) == REG_ANY)
- ? PREGf_ANCH_MBOL
- : PREGf_ANCH_SBOL;
- RExC_rx->intflags |= (type | PREGf_IMPLICIT);
- first = NEXTOPER(first);
- goto again;
- }
- if (sawplus && !sawminmod && !sawlookahead
- && (!sawopen || !RExC_sawback)
- && !pRExC_state->code_blocks) /* May examine pos and $& */
- /* x+ must match at the 1st pos of run of x's */
- RExC_rx->intflags |= PREGf_SKIP;
-
- /* Scan is after the zeroth branch, first is atomic matcher. */
-#ifdef TRIE_STUDY_OPT
- DEBUG_PARSE_r(
- if (!restudied)
- Perl_re_printf( aTHX_ "first at %" IVdf "\n",
- (IV)(first - scan + 1))
- );
-#else
- DEBUG_PARSE_r(
- Perl_re_printf( aTHX_ "first at %" IVdf "\n",
- (IV)(first - scan + 1))
- );
-#endif
-
-
- /*
- * If there's something expensive in the r.e., find the
- * longest literal string that must appear and make it the
- * regmust. Resolve ties in favor of later strings, since
- * the regstart check works with the beginning of the r.e.
- * and avoiding duplication strengthens checking. Not a
- * strong reason, but sufficient in the absence of others.
- * [Now we resolve ties in favor of the earlier string if
- * it happens that c_offset_min has been invalidated, since the
- * earlier string may buy us something the later one won't.]
- */
-
- data.substrs[0].str = newSVpvs("");
- data.substrs[1].str = newSVpvs("");
- data.last_found = newSVpvs("");
- data.cur_is_floating = 0; /* initially any found substring is fixed */
- ENTER_with_name("study_chunk");
- SAVEFREESV(data.substrs[0].str);
- SAVEFREESV(data.substrs[1].str);
- SAVEFREESV(data.last_found);
- first = scan;
- if (!RExC_rxi->regstclass) {
- ssc_init(pRExC_state, &ch_class);
- data.start_class = &ch_class;
- stclass_flag = SCF_DO_STCLASS_AND;
- } else /* XXXX Check for BOUND? */
- stclass_flag = 0;
- data.last_closep = &last_close;
-
- DEBUG_RExC_seen();
- /*
- * MAIN ENTRY FOR study_chunk() FOR m/PATTERN/
- * (NO top level branches)
- */
- minlen = study_chunk(pRExC_state, &first, &minlen, &fake,
- scan + RExC_size, /* Up to end */
- &data, -1, 0, NULL,
- SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
- | (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
- 0, TRUE);
-
-
- CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
-
-
- if ( RExC_total_parens == 1 && !data.cur_is_floating
- && data.last_start_min == 0 && data.last_end > 0
- && !RExC_seen_zerolen
- && !(RExC_seen & REG_VERBARG_SEEN)
- && !(RExC_seen & REG_GPOS_SEEN)
- ){
- RExC_rx->extflags |= RXf_CHECK_ALL;
- }
- scan_commit(pRExC_state, &data,&minlen, 0);
-
-
- /* XXX this is done in reverse order because that's the way the
- * code was before it was parameterised. Don't know whether it
- * actually needs doing in reverse order. DAPM */
- for (i = 1; i >= 0; i--) {
- longest_length[i] = CHR_SVLEN(data.substrs[i].str);
-
- if ( !( i
- && SvCUR(data.substrs[0].str) /* ok to leave SvCUR */
- && data.substrs[0].min_offset
- == data.substrs[1].min_offset
- && SvCUR(data.substrs[0].str)
- == SvCUR(data.substrs[1].str)
- )
- && S_setup_longest (aTHX_ pRExC_state,
- &(RExC_rx->substrs->data[i]),
- &(data.substrs[i]),
- longest_length[i]))
- {
- RExC_rx->substrs->data[i].min_offset =
- data.substrs[i].min_offset - data.substrs[i].lookbehind;
-
- RExC_rx->substrs->data[i].max_offset = data.substrs[i].max_offset;
- /* Don't offset infinity */
- if (data.substrs[i].max_offset < OPTIMIZE_INFTY)
- RExC_rx->substrs->data[i].max_offset -= data.substrs[i].lookbehind;
- SvREFCNT_inc_simple_void_NN(data.substrs[i].str);
- }
- else {
- RExC_rx->substrs->data[i].substr = NULL;
- RExC_rx->substrs->data[i].utf8_substr = NULL;
- longest_length[i] = 0;
- }
- }
-
- LEAVE_with_name("study_chunk");
-
- if (RExC_rxi->regstclass
- && (OP(RExC_rxi->regstclass) == REG_ANY || OP(RExC_rxi->regstclass) == SANY))
- RExC_rxi->regstclass = NULL;
-
- if ((!(RExC_rx->substrs->data[0].substr || RExC_rx->substrs->data[0].utf8_substr)
- || RExC_rx->substrs->data[0].min_offset)
- && stclass_flag
- && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
- && is_ssc_worth_it(pRExC_state, data.start_class))
- {
- const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
-
- ssc_finalize(pRExC_state, data.start_class);
-
- Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
- StructCopy(data.start_class,
- (regnode_ssc*)RExC_rxi->data->data[n],
- regnode_ssc);
- RExC_rxi->regstclass = (regnode*)RExC_rxi->data->data[n];
- RExC_rx->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
- DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
- regprop(RExC_rx, sv, (regnode*)data.start_class, NULL, pRExC_state);
- Perl_re_printf( aTHX_
- "synthetic stclass \"%s\".\n",
- SvPVX_const(sv));});
- data.start_class = NULL;
- }
-
- /* A temporary algorithm prefers floated substr to fixed one of
- * same length to dig more info. */
- i = (longest_length[0] <= longest_length[1]);
- RExC_rx->substrs->check_ix = i;
- RExC_rx->check_end_shift = RExC_rx->substrs->data[i].end_shift;
- RExC_rx->check_substr = RExC_rx->substrs->data[i].substr;
- RExC_rx->check_utf8 = RExC_rx->substrs->data[i].utf8_substr;
- RExC_rx->check_offset_min = RExC_rx->substrs->data[i].min_offset;
- RExC_rx->check_offset_max = RExC_rx->substrs->data[i].max_offset;
- if (!i && (RExC_rx->intflags & (PREGf_ANCH_SBOL|PREGf_ANCH_GPOS)))
- RExC_rx->intflags |= PREGf_NOSCAN;
-
- if ((RExC_rx->check_substr || RExC_rx->check_utf8) ) {
- RExC_rx->extflags |= RXf_USE_INTUIT;
- if (SvTAIL(RExC_rx->check_substr ? RExC_rx->check_substr : RExC_rx->check_utf8))
- RExC_rx->extflags |= RXf_INTUIT_TAIL;
- }
-
- /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
- if ( (STRLEN)minlen < longest_length[1] )
- minlen= longest_length[1];
- if ( (STRLEN)minlen < longest_length[0] )
- minlen= longest_length[0];
- */
- }
- else {
- /* Several toplevels. Best we can is to set minlen. */
- SSize_t fake;
- regnode_ssc ch_class;
- SSize_t last_close = 0;
-
- DEBUG_PARSE_r(Perl_re_printf( aTHX_ "\nMulti Top Level\n"));
-
- scan = RExC_rxi->program + 1;
- ssc_init(pRExC_state, &ch_class);
- data.start_class = &ch_class;
- data.last_closep = &last_close;
-
- DEBUG_RExC_seen();
- /*
- * MAIN ENTRY FOR study_chunk() FOR m/P1|P2|.../
- * (patterns WITH top level branches)
- */
- minlen = study_chunk(pRExC_state,
- &scan, &minlen, &fake, scan + RExC_size, &data, -1, 0, NULL,
- SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied
- ? SCF_TRIE_DOING_RESTUDY
- : 0),
- 0, TRUE);
-
- CHECK_RESTUDY_GOTO_butfirst(NOOP);
-
- RExC_rx->check_substr = NULL;
- RExC_rx->check_utf8 = NULL;
- RExC_rx->substrs->data[0].substr = NULL;
- RExC_rx->substrs->data[0].utf8_substr = NULL;
- RExC_rx->substrs->data[1].substr = NULL;
- RExC_rx->substrs->data[1].utf8_substr = NULL;
-
- if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
- && is_ssc_worth_it(pRExC_state, data.start_class))
- {
- const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
-
- ssc_finalize(pRExC_state, data.start_class);
-
- Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
- StructCopy(data.start_class,
- (regnode_ssc*)RExC_rxi->data->data[n],
- regnode_ssc);
- RExC_rxi->regstclass = (regnode*)RExC_rxi->data->data[n];
- RExC_rx->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
- DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
- regprop(RExC_rx, sv, (regnode*)data.start_class, NULL, pRExC_state);
- Perl_re_printf( aTHX_
- "synthetic stclass \"%s\".\n",
- SvPVX_const(sv));});
- data.start_class = NULL;
- }
- }
-
- if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) {
- RExC_rx->extflags |= RXf_UNBOUNDED_QUANTIFIER_SEEN;
- RExC_rx->maxlen = REG_INFTY;
- }
- else {
- RExC_rx->maxlen = RExC_maxlen;
- }
-
- /* Guard against an embedded (?=) or (?<=) with a longer minlen than
- the "real" pattern. */
- DEBUG_OPTIMISE_r({
- Perl_re_printf( aTHX_ "minlen: %" IVdf " RExC_rx->minlen:%" IVdf " maxlen:%" IVdf "\n",
- (IV)minlen, (IV)RExC_rx->minlen, (IV)RExC_maxlen);
- });
- RExC_rx->minlenret = minlen;
- if (RExC_rx->minlen < minlen)
- RExC_rx->minlen = minlen;
-
- if (RExC_seen & REG_RECURSE_SEEN ) {
- RExC_rx->intflags |= PREGf_RECURSE_SEEN;
- Newx(RExC_rx->recurse_locinput, RExC_rx->nparens + 1, char *);
- }
- if (RExC_seen & REG_GPOS_SEEN)
- RExC_rx->intflags |= PREGf_GPOS_SEEN;
- if (RExC_seen & REG_LOOKBEHIND_SEEN)
- RExC_rx->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the
- lookbehind */
- if (pRExC_state->code_blocks)
- RExC_rx->extflags |= RXf_EVAL_SEEN;
- if (RExC_seen & REG_VERBARG_SEEN)
- {
- RExC_rx->intflags |= PREGf_VERBARG_SEEN;
- RExC_rx->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
- }
- if (RExC_seen & REG_CUTGROUP_SEEN)
- RExC_rx->intflags |= PREGf_CUTGROUP_SEEN;
- if (pm_flags & PMf_USE_RE_EVAL)
- RExC_rx->intflags |= PREGf_USE_RE_EVAL;
- if (RExC_paren_names)
- RXp_PAREN_NAMES(RExC_rx) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
- else
- RXp_PAREN_NAMES(RExC_rx) = NULL;
-
- /* If we have seen an anchor in our pattern then we set the extflag RXf_IS_ANCHORED
- * so it can be used in pp.c */
- if (RExC_rx->intflags & PREGf_ANCH)
- RExC_rx->extflags |= RXf_IS_ANCHORED;
-
-
- {
- /* this is used to identify "special" patterns that might result
- * in Perl NOT calling the regex engine and instead doing the match "itself",
- * particularly special cases in split//. By having the regex compiler
- * do this pattern matching at a regop level (instead of by inspecting the pattern)
- * we avoid weird issues with equivalent patterns resulting in different behavior,
- * AND we allow non Perl engines to get the same optimizations by the setting the
- * flags appropriately - Yves */
- regnode *first = RExC_rxi->program + 1;
- U8 fop = OP(first);
- regnode *next = regnext(first);
- U8 nop = OP(next);
-
- if (PL_regkind[fop] == NOTHING && nop == END)
- RExC_rx->extflags |= RXf_NULL;
- else if ((fop == MBOL || (fop == SBOL && !first->flags)) && nop == END)
- /* when fop is SBOL first->flags will be true only when it was
- * produced by parsing /\A/, and not when parsing /^/. This is
- * very important for the split code as there we want to
- * treat /^/ as /^/m, but we do not want to treat /\A/ as /^/m.
- * See rt #122761 for more details. -- Yves */
- RExC_rx->extflags |= RXf_START_ONLY;
- else if (fop == PLUS
- && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE
- && nop == END)
- RExC_rx->extflags |= RXf_WHITE;
- else if ( RExC_rx->extflags & RXf_SPLIT
- && (PL_regkind[fop] == EXACT && ! isEXACTFish(fop))
- && STR_LEN(first) == 1
- && *(STRING(first)) == ' '
- && nop == END )
- RExC_rx->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
-
- }
-
- if (RExC_contains_locale) {
- RXp_EXTFLAGS(RExC_rx) |= RXf_TAINTED;
- }
-
-#ifdef DEBUGGING
- if (RExC_paren_names) {
- RExC_rxi->name_list_idx = add_data( pRExC_state, STR_WITH_LEN("a"));
- RExC_rxi->data->data[RExC_rxi->name_list_idx]
- = (void*)SvREFCNT_inc(RExC_paren_name_list);
- } else
-#endif
- RExC_rxi->name_list_idx = 0;
-
- while ( RExC_recurse_count > 0 ) {
- const regnode *scan = RExC_recurse[ --RExC_recurse_count ];
- /*
- * This data structure is set up in study_chunk() and is used
- * to calculate the distance between a GOSUB regopcode and
- * the OPEN/CURLYM (CURLYM's are special and can act like OPEN's)
- * it refers to.
- *
- * If for some reason someone writes code that optimises
- * away a GOSUB opcode then the assert should be changed to
- * an if(scan) to guard the ARG2L_SET() - Yves
+ /* we make the assumption here that each op in the list of
+ * op_siblings maps to one SV pushed onto the stack,
+ * except for code blocks, with have both an OP_NULL and
+ * an OP_CONST.
+ * This allows us to match up the list of SVs against the
+ * list of OPs to find the next code block.
*
- */
- assert(scan && OP(scan) == GOSUB);
- ARG2L_SET( scan, RExC_open_parens[ARG(scan)] - REGNODE_OFFSET(scan));
- }
-
- Newxz(RExC_rx->offs, RExC_total_parens, regexp_paren_pair);
- /* assume we don't need to swap parens around before we match */
- DEBUG_TEST_r({
- Perl_re_printf( aTHX_ "study_chunk_recursed_count: %lu\n",
- (unsigned long)RExC_study_chunk_recursed_count);
- });
- DEBUG_DUMP_r({
- DEBUG_RExC_seen();
- Perl_re_printf( aTHX_ "Final program:\n");
- regdump(RExC_rx);
- });
-
- if (RExC_open_parens) {
- Safefree(RExC_open_parens);
- RExC_open_parens = NULL;
- }
- if (RExC_close_parens) {
- Safefree(RExC_close_parens);
- RExC_close_parens = NULL;
- }
-
-#ifdef USE_ITHREADS
- /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
- * by setting the regexp SV to readonly-only instead. If the
- * pattern's been recompiled, the USEDness should remain. */
- if (old_re && SvREADONLY(old_re))
- SvREADONLY_on(Rx);
-#endif
- return Rx;
-}
-
-
-SV*
-Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
- const U32 flags)
-{
- PERL_ARGS_ASSERT_REG_NAMED_BUFF;
-
- PERL_UNUSED_ARG(value);
-
- if (flags & RXapif_FETCH) {
- return reg_named_buff_fetch(rx, key, flags);
- } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
- Perl_croak_no_modify();
- return NULL;
- } else if (flags & RXapif_EXISTS) {
- return reg_named_buff_exists(rx, key, flags)
- ? &PL_sv_yes
- : &PL_sv_no;
- } else if (flags & RXapif_REGNAMES) {
- return reg_named_buff_all(rx, flags);
- } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
- return reg_named_buff_scalar(rx, flags);
- } else {
- Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
- return NULL;
- }
-}
-
-SV*
-Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
- const U32 flags)
-{
- PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
- PERL_UNUSED_ARG(lastkey);
-
- if (flags & RXapif_FIRSTKEY)
- return reg_named_buff_firstkey(rx, flags);
- else if (flags & RXapif_NEXTKEY)
- return reg_named_buff_nextkey(rx, flags);
- else {
- Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter",
- (int)flags);
- return NULL;
- }
-}
+ * Note that PUSHMARK PADSV PADSV ..
+ * is optimised to
+ * PADRANGE PADSV PADSV ..
+ * so the alignment still works. */
-SV*
-Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
- const U32 flags)
-{
- SV *ret;
- struct regexp *const rx = ReANY(r);
-
- PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
-
- if (rx && RXp_PAREN_NAMES(rx)) {
- HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
- if (he_str) {
- IV i;
- SV* sv_dat=HeVAL(he_str);
- I32 *nums=(I32*)SvPVX(sv_dat);
- AV * const retarray = (flags & RXapif_ALL) ? newAV() : NULL;
- for ( i=0; i<SvIVX(sv_dat); i++ ) {
- if ((I32)(rx->nparens) >= nums[i]
- && rx->offs[nums[i]].start != -1
- && rx->offs[nums[i]].end != -1)
- {
- ret = newSVpvs("");
- CALLREG_NUMBUF_FETCH(r, nums[i], ret);
- if (!retarray)
- return ret;
- } else {
- if (retarray)
- ret = newSVsv(&PL_sv_undef);
- }
- if (retarray)
- av_push(retarray, ret);
+ if (oplist) {
+ if (oplist->op_type == OP_NULL
+ && (oplist->op_flags & OPf_SPECIAL))
+ {
+ assert(n < pRExC_state->code_blocks->count);
+ pRExC_state->code_blocks->cb[n].start = pat ? SvCUR(pat) : 0;
+ pRExC_state->code_blocks->cb[n].block = oplist;
+ pRExC_state->code_blocks->cb[n].src_regex = NULL;
+ n++;
+ code = 1;
+ oplist = OpSIBLING(oplist); /* skip CONST */
+ assert(oplist);
}
- if (retarray)
- return newRV_noinc(MUTABLE_SV(retarray));
+ oplist = OpSIBLING(oplist);;
}
- }
- return NULL;
-}
-
-bool
-Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
- const U32 flags)
-{
- struct regexp *const rx = ReANY(r);
- PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
+ /* apply magic and QR overloading to arg */
- if (rx && RXp_PAREN_NAMES(rx)) {
- if (flags & RXapif_ALL) {
- return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
- } else {
- SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
+ SvGETMAGIC(msv);
+ if (SvROK(msv) && SvAMAGIC(msv)) {
+ SV *sv = AMG_CALLunary(msv, regexp_amg);
if (sv) {
- SvREFCNT_dec_NN(sv);
- return TRUE;
- } else {
- return FALSE;
- }
- }
- } else {
- return FALSE;
- }
-}
-
-SV*
-Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
-{
- struct regexp *const rx = ReANY(r);
-
- PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
-
- if ( rx && RXp_PAREN_NAMES(rx) ) {
- (void)hv_iterinit(RXp_PAREN_NAMES(rx));
-
- return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
- } else {
- return FALSE;
- }
-}
-
-SV*
-Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
-{
- struct regexp *const rx = ReANY(r);
- DECLARE_AND_GET_RE_DEBUG_FLAGS;
-
- PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
-
- if (rx && RXp_PAREN_NAMES(rx)) {
- HV *hv = RXp_PAREN_NAMES(rx);
- HE *temphe;
- while ( (temphe = hv_iternext_flags(hv, 0)) ) {
- IV i;
- IV parno = 0;
- SV* sv_dat = HeVAL(temphe);
- I32 *nums = (I32*)SvPVX(sv_dat);
- for ( i = 0; i < SvIVX(sv_dat); i++ ) {
- if ((I32)(rx->lastparen) >= nums[i] &&
- rx->offs[nums[i]].start != -1 &&
- rx->offs[nums[i]].end != -1)
- {
- parno = nums[i];
- break;
- }
- }
- if (parno || flags & RXapif_ALL) {
- return newSVhek(HeKEY_hek(temphe));
+ if (SvROK(sv))
+ sv = SvRV(sv);
+ if (SvTYPE(sv) != SVt_REGEXP)
+ Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
+ msv = sv;
}
}
- }
- return NULL;
-}
-SV*
-Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
-{
- SV *ret;
- AV *av;
- SSize_t length;
- struct regexp *const rx = ReANY(r);
-
- PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
-
- if (rx && RXp_PAREN_NAMES(rx)) {
- if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
- return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
- } else if (flags & RXapif_ONE) {
- ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
- av = MUTABLE_AV(SvRV(ret));
- length = av_count(av);
- SvREFCNT_dec_NN(ret);
- return newSViv(length);
- } else {
- Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar",
- (int)flags);
- return NULL;
+ /* try concatenation overload ... */
+ if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
+ (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
+ {
+ sv_setsv(pat, sv);
+ /* overloading involved: all bets are off over literal
+ * code. Pretend we haven't seen it */
+ if (n)
+ pRExC_state->code_blocks->count -= n;
+ n = 0;
}
- }
- return &PL_sv_undef;
-}
+ else {
+ /* ... or failing that, try "" overload */
+ while (SvAMAGIC(msv)
+ && (sv = AMG_CALLunary(msv, string_amg))
+ && sv != msv
+ && !( SvROK(msv)
+ && SvROK(sv)
+ && SvRV(msv) == SvRV(sv))
+ ) {
+ msv = sv;
+ SvGETMAGIC(msv);
+ }
+ if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
+ msv = SvRV(msv);
-SV*
-Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
-{
- struct regexp *const rx = ReANY(r);
- AV *av = newAV();
-
- PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
-
- if (rx && RXp_PAREN_NAMES(rx)) {
- HV *hv= RXp_PAREN_NAMES(rx);
- HE *temphe;
- (void)hv_iterinit(hv);
- while ( (temphe = hv_iternext_flags(hv, 0)) ) {
- IV i;
- IV parno = 0;
- SV* sv_dat = HeVAL(temphe);
- I32 *nums = (I32*)SvPVX(sv_dat);
- for ( i = 0; i < SvIVX(sv_dat); i++ ) {
- if ((I32)(rx->lastparen) >= nums[i] &&
- rx->offs[nums[i]].start != -1 &&
- rx->offs[nums[i]].end != -1)
- {
- parno = nums[i];
- break;
+ if (pat) {
+ /* this is a partially unrolled
+ * sv_catsv_nomg(pat, msv);
+ * that allows us to adjust code block indices if
+ * needed */
+ STRLEN dlen;
+ char *dst = SvPV_force_nomg(pat, dlen);
+ orig_patlen = dlen;
+ if (SvUTF8(msv) && !SvUTF8(pat)) {
+ S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n);
+ sv_setpvn(pat, dst, dlen);
+ SvUTF8_on(pat);
}
+ sv_catsv_nomg(pat, msv);
+ rx = msv;
}
- if (parno || flags & RXapif_ALL) {
- av_push(av, newSVhek(HeKEY_hek(temphe)));
- }
- }
- }
-
- return newRV_noinc(MUTABLE_SV(av));
-}
-
-void
-Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
- SV * const sv)
-{
- struct regexp *const rx = ReANY(r);
- char *s = NULL;
- SSize_t i = 0;
- SSize_t s1, t1;
- I32 n = paren;
-
- PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
-
- if ( n == RX_BUFF_IDX_CARET_PREMATCH
- || n == RX_BUFF_IDX_CARET_FULLMATCH
- || n == RX_BUFF_IDX_CARET_POSTMATCH
- )
- {
- bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
- if (!keepcopy) {
- /* on something like
- * $r = qr/.../;
- * /$qr/p;
- * the KEEPCOPY is set on the PMOP rather than the regex */
- if (PL_curpm && r == PM_GETRE(PL_curpm))
- keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
- }
- if (!keepcopy)
- goto ret_undef;
- }
-
- if (!rx->subbeg)
- goto ret_undef;
-
- if (n == RX_BUFF_IDX_CARET_FULLMATCH)
- /* no need to distinguish between them any more */
- n = RX_BUFF_IDX_FULLMATCH;
-
- if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
- && rx->offs[0].start != -1)
- {
- /* $`, ${^PREMATCH} */
- i = rx->offs[0].start;
- s = rx->subbeg;
- }
- else
- if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
- && rx->offs[0].end != -1)
- {
- /* $', ${^POSTMATCH} */
- s = rx->subbeg - rx->suboffset + rx->offs[0].end;
- i = rx->sublen + rx->suboffset - rx->offs[0].end;
- }
- else
- if (inRANGE(n, 0, (I32)rx->nparens) &&
- (s1 = rx->offs[n].start) != -1 &&
- (t1 = rx->offs[n].end) != -1)
- {
- /* $&, ${^MATCH}, $1 ... */
- i = t1 - s1;
- s = rx->subbeg + s1 - rx->suboffset;
- } else {
- goto ret_undef;
- }
-
- assert(s >= rx->subbeg);
- assert((STRLEN)rx->sublen >= (STRLEN)((s - rx->subbeg) + i) );
- if (i >= 0) {
-#ifdef NO_TAINT_SUPPORT
- sv_setpvn(sv, s, i);
-#else
- const int oldtainted = TAINT_get;
- TAINT_NOT;
- sv_setpvn(sv, s, i);
- TAINT_set(oldtainted);
-#endif
- if (RXp_MATCH_UTF8(rx))
- SvUTF8_on(sv);
- else
- SvUTF8_off(sv);
- if (TAINTING_get) {
- if (RXp_MATCH_TAINTED(rx)) {
- if (SvTYPE(sv) >= SVt_PVMG) {
- MAGIC* const mg = SvMAGIC(sv);
- MAGIC* mgt;
- TAINT;
- SvMAGIC_set(sv, mg->mg_moremagic);
- SvTAINT(sv);
- if ((mgt = SvMAGIC(sv))) {
- mg->mg_moremagic = mgt;
- SvMAGIC_set(sv, mg);
- }
+ else {
+ /* We have only one SV to process, but we need to verify
+ * it is properly null terminated or we will fail asserts
+ * later. In theory we probably shouldn't get such SV's,
+ * but if we do we should handle it gracefully. */
+ if ( SvTYPE(msv) != SVt_PV || (SvLEN(msv) > SvCUR(msv) && *(SvEND(msv)) == 0) || SvIsCOW_shared_hash(msv) ) {
+ /* not a string, or a string with a trailing null */
+ pat = msv;
} else {
- TAINT;
- SvTAINT(sv);
+ /* a string with no trailing null, we need to copy it
+ * so it has a trailing null */
+ pat = sv_2mortal(newSVsv(msv));
}
- } else
- SvTAINTED_off(sv);
- }
- } else {
- ret_undef:
- sv_set_undef(sv);
- return;
- }
-}
-
-void
-Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
- SV const * const value)
-{
- PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
-
- PERL_UNUSED_ARG(rx);
- PERL_UNUSED_ARG(paren);
- PERL_UNUSED_ARG(value);
-
- if (!PL_localizing)
- Perl_croak_no_modify();
-}
-
-I32
-Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
- const I32 paren)
-{
- struct regexp *const rx = ReANY(r);
- I32 i;
- I32 s1, t1;
-
- PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
+ }
- if ( paren == RX_BUFF_IDX_CARET_PREMATCH
- || paren == RX_BUFF_IDX_CARET_FULLMATCH
- || paren == RX_BUFF_IDX_CARET_POSTMATCH
- )
- {
- bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
- if (!keepcopy) {
- /* on something like
- * $r = qr/.../;
- * /$qr/p;
- * the KEEPCOPY is set on the PMOP rather than the regex */
- if (PL_curpm && r == PM_GETRE(PL_curpm))
- keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
- }
- if (!keepcopy)
- goto warn_undef;
- }
+ if (code)
+ pRExC_state->code_blocks->cb[n-1].end = SvCUR(pat)-1;
+ }
- /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
- switch (paren) {
- case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
- case RX_BUFF_IDX_PREMATCH: /* $` */
- if (rx->offs[0].start != -1) {
- i = rx->offs[0].start;
- if (i > 0) {
- s1 = 0;
- t1 = i;
- goto getlen;
- }
- }
- return 0;
+ /* extract any code blocks within any embedded qr//'s */
+ if (rx && SvTYPE(rx) == SVt_REGEXP
+ && RX_ENGINE((REGEXP*)rx)->op_comp)
+ {
- case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
- case RX_BUFF_IDX_POSTMATCH: /* $' */
- if (rx->offs[0].end != -1) {
- i = rx->sublen - rx->offs[0].end;
- if (i > 0) {
- s1 = rx->offs[0].end;
- t1 = rx->sublen;
- goto getlen;
- }
- }
- return 0;
+ RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
+ if (ri->code_blocks && ri->code_blocks->count) {
+ int i;
+ /* the presence of an embedded qr// with code means
+ * we should always recompile: the text of the
+ * qr// may not have changed, but it may be a
+ * different closure than last time */
+ *recompile_p = 1;
+ if (pRExC_state->code_blocks) {
+ int new_count = pRExC_state->code_blocks->count
+ + ri->code_blocks->count;
+ Renew(pRExC_state->code_blocks->cb,
+ new_count, struct reg_code_block);
+ pRExC_state->code_blocks->count = new_count;
+ }
+ else
+ pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_
+ ri->code_blocks->count);
- default: /* $& / ${^MATCH}, $1, $2, ... */
- if (paren <= (I32)rx->nparens &&
- (s1 = rx->offs[paren].start) != -1 &&
- (t1 = rx->offs[paren].end) != -1)
- {
- i = t1 - s1;
- goto getlen;
- } else {
- warn_undef:
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit((const SV *)sv);
- return 0;
+ for (i=0; i < ri->code_blocks->count; i++) {
+ struct reg_code_block *src, *dst;
+ STRLEN offset = orig_patlen
+ + ReANY((REGEXP *)rx)->pre_prefix;
+ assert(n < pRExC_state->code_blocks->count);
+ src = &ri->code_blocks->cb[i];
+ dst = &pRExC_state->code_blocks->cb[n];
+ dst->start = src->start + offset;
+ dst->end = src->end + offset;
+ dst->block = src->block;
+ dst->src_regex = (REGEXP*) SvREFCNT_inc( (SV*)
+ src->src_regex
+ ? src->src_regex
+ : (REGEXP*)rx);
+ n++;
+ }
+ }
}
}
- getlen:
- if (i > 0 && RXp_MATCH_UTF8(rx)) {
- const char * const s = rx->subbeg - rx->suboffset + s1;
- const U8 *ep;
- STRLEN el;
-
- i = t1 - s1;
- if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
- i = el;
- }
- return i;
-}
+ /* avoid calling magic multiple times on a single element e.g. =~ $qr */
+ if (alloced)
+ SvSETMAGIC(pat);
-SV*
-Perl_reg_qr_package(pTHX_ REGEXP * const rx)
-{
- PERL_ARGS_ASSERT_REG_QR_PACKAGE;
- PERL_UNUSED_ARG(rx);
- if (0)
- return NULL;
- else
- return newSVpvs("Regexp");
+ return pat;
}
-/* Scans the name of a named buffer from the pattern.
- * If flags is REG_RSN_RETURN_NULL returns null.
- * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
- * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
- * to the parsed name as looked up in the RExC_paren_names hash.
- * If there is an error throws a vFAIL().. type exception.
- */
-#define REG_RSN_RETURN_NULL 0
-#define REG_RSN_RETURN_NAME 1
-#define REG_RSN_RETURN_DATA 2
-STATIC SV*
-S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
-{
- char *name_start = RExC_parse;
- SV* sv_name;
+/* see if there are any run-time code blocks in the pattern.
+ * False positives are allowed */
- PERL_ARGS_ASSERT_REG_SCAN_NAME;
+static bool
+S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
+ char *pat, STRLEN plen)
+{
+ int n = 0;
+ STRLEN s;
- assert (RExC_parse <= RExC_end);
- if (RExC_parse == RExC_end) NOOP;
- else if (isIDFIRST_lazy_if_safe(RExC_parse, RExC_end, UTF)) {
- /* Note that the code here assumes well-formed UTF-8. Skip IDFIRST by
- * using do...while */
- if (UTF)
- do {
- RExC_parse += UTF8SKIP(RExC_parse);
- } while ( RExC_parse < RExC_end
- && isWORDCHAR_utf8_safe((U8*)RExC_parse, (U8*) RExC_end));
- else
- do {
- RExC_parse++;
- } while (RExC_parse < RExC_end && isWORDCHAR(*RExC_parse));
- } else {
- RExC_parse++; /* so the <- from the vFAIL is after the offending
- character */
- vFAIL("Group name must start with a non-digit word character");
- }
- sv_name = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
- SVs_TEMP | (UTF ? SVf_UTF8 : 0));
- if ( flags == REG_RSN_RETURN_NAME)
- return sv_name;
- else if (flags==REG_RSN_RETURN_DATA) {
- HE *he_str = NULL;
- SV *sv_dat = NULL;
- if ( ! sv_name ) /* should not happen*/
- Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
- if (RExC_paren_names)
- he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
- if ( he_str )
- sv_dat = HeVAL(he_str);
- if ( ! sv_dat ) { /* Didn't find group */
+ PERL_UNUSED_CONTEXT;
- /* It might be a forward reference; we can't fail until we
- * know, by completing the parse to get all the groups, and
- * then reparsing */
- if (ALL_PARENS_COUNTED) {
- vFAIL("Reference to nonexistent named group");
- }
- else {
- REQUIRE_PARENS_PASS;
- }
+ for (s = 0; s < plen; s++) {
+ if ( pRExC_state->code_blocks
+ && n < pRExC_state->code_blocks->count
+ && s == pRExC_state->code_blocks->cb[n].start)
+ {
+ s = pRExC_state->code_blocks->cb[n].end;
+ n++;
+ continue;
}
- return sv_dat;
+ /* TODO ideally should handle [..], (#..), /#.../x to reduce false
+ * positives here */
+ if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
+ (pat[s+2] == '{'
+ || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
+ )
+ return 1;
}
-
- Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
- (unsigned long) flags);
+ return 0;
}
-#define DEBUG_PARSE_MSG(funcname) DEBUG_PARSE_r({ \
- if (RExC_lastparse!=RExC_parse) { \
- Perl_re_printf( aTHX_ "%s", \
- Perl_pv_pretty(aTHX_ RExC_mysv1, RExC_parse, \
- RExC_end - RExC_parse, 16, \
- "", "", \
- PERL_PV_ESCAPE_UNI_DETECT | \
- PERL_PV_PRETTY_ELLIPSES | \
- PERL_PV_PRETTY_LTGT | \
- PERL_PV_ESCAPE_RE | \
- PERL_PV_PRETTY_EXACTSIZE \
- ) \
- ); \
- } else \
- Perl_re_printf( aTHX_ "%16s",""); \
- \
- if (RExC_lastnum!=RExC_emit) \
- Perl_re_printf( aTHX_ "|%4zu", RExC_emit); \
- else \
- Perl_re_printf( aTHX_ "|%4s",""); \
- Perl_re_printf( aTHX_ "|%*s%-4s", \
- (int)((depth*2)), "", \
- (funcname) \
- ); \
- RExC_lastnum=RExC_emit; \
- RExC_lastparse=RExC_parse; \
-})
-
-
-
-#define DEBUG_PARSE(funcname) DEBUG_PARSE_r({ \
- DEBUG_PARSE_MSG((funcname)); \
- Perl_re_printf( aTHX_ "%4s","\n"); \
-})
-#define DEBUG_PARSE_FMT(funcname,fmt,args) DEBUG_PARSE_r({\
- DEBUG_PARSE_MSG((funcname)); \
- Perl_re_printf( aTHX_ fmt "\n",args); \
-})
-
-/* This section of code defines the inversion list object and its methods. The
- * interfaces are highly subject to change, so as much as possible is static to
- * this file. An inversion list is here implemented as a malloc'd C UV array
- * as an SVt_INVLIST scalar.
+/* Handle run-time code blocks. We will already have compiled any direct
+ * or indirect literal code blocks. Now, take the pattern 'pat' and make a
+ * copy of it, but with any literal code blocks blanked out and
+ * appropriate chars escaped; then feed it into
*
- * An inversion list for Unicode is an array of code points, sorted by ordinal
- * number. Each element gives the code point that begins a range that extends
- * up-to but not including the code point given by the next element. The final
- * element gives the first code point of a range that extends to the platform's
- * infinity. The even-numbered elements (invlist[0], invlist[2], invlist[4],
- * ...) give ranges whose code points are all in the inversion list. We say
- * that those ranges are in the set. The odd-numbered elements give ranges
- * whose code points are not in the inversion list, and hence not in the set.
- * Thus, element [0] is the first code point in the list. Element [1]
- * is the first code point beyond that not in the list; and element [2] is the
- * first code point beyond that that is in the list. In other words, the first
- * range is invlist[0]..(invlist[1]-1), and all code points in that range are
- * in the inversion list. The second range is invlist[1]..(invlist[2]-1), and
- * all code points in that range are not in the inversion list. The third
- * range invlist[2]..(invlist[3]-1) gives code points that are in the inversion
- * list, and so forth. Thus every element whose index is divisible by two
- * gives the beginning of a range that is in the list, and every element whose
- * index is not divisible by two gives the beginning of a range not in the
- * list. If the final element's index is divisible by two, the inversion list
- * extends to the platform's infinity; otherwise the highest code point in the
- * inversion list is the contents of that element minus 1.
+ * eval "qr'modified_pattern'"
*
- * A range that contains just a single code point N will look like
- * invlist[i] == N
- * invlist[i+1] == N+1
+ * For example,
*
- * If N is UV_MAX (the highest representable code point on the machine), N+1 is
- * impossible to represent, so element [i+1] is omitted. The single element
- * inversion list
- * invlist[0] == UV_MAX
- * contains just UV_MAX, but is interpreted as matching to infinity.
+ * a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
*
- * Taking the complement (inverting) an inversion list is quite simple, if the
- * first element is 0, remove it; otherwise add a 0 element at the beginning.
- * This implementation reserves an element at the beginning of each inversion
- * list to always contain 0; there is an additional flag in the header which
- * indicates if the list begins at the 0, or is offset to begin at the next
- * element. This means that the inversion list can be inverted without any
- * copying; just flip the flag.
+ * becomes
*
- * More about inversion lists can be found in "Unicode Demystified"
- * Chapter 13 by Richard Gillam, published by Addison-Wesley.
+ * qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
*
- * The inversion list data structure is currently implemented as an SV pointing
- * to an array of UVs that the SV thinks are bytes. This allows us to have an
- * array of UV whose memory management is automatically handled by the existing
- * facilities for SV's.
+ * After eval_sv()-ing that, grab any new code blocks from the returned qr
+ * and merge them with any code blocks of the original regexp.
*
- * Some of the methods should always be private to the implementation, and some
- * should eventually be made public */
+ * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
+ * instead, just save the qr and return FALSE; this tells our caller that
+ * the original pattern needs upgrading to utf8.
+ */
-/* The header definitions are in F<invlist_inline.h> */
+static bool
+S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
+ char *pat, STRLEN plen)
+{
+ SV *qr;
-#ifndef PERL_IN_XSUB_RE
+ DECLARE_AND_GET_RE_DEBUG_FLAGS;
-PERL_STATIC_INLINE UV*
-S__invlist_array_init(SV* const invlist, const bool will_have_0)
-{
- /* Returns a pointer to the first element in the inversion list's array.
- * This is called upon initialization of an inversion list. Where the
- * array begins depends on whether the list has the code point U+0000 in it
- * or not. The other parameter tells it whether the code that follows this
- * call is about to put a 0 in the inversion list or not. The first
- * element is either the element reserved for 0, if TRUE, or the element
- * after it, if FALSE */
+ if (pRExC_state->runtime_code_qr) {
+ /* this is the second time we've been called; this should
+ * only happen if the main pattern got upgraded to utf8
+ * during compilation; re-use the qr we compiled first time
+ * round (which should be utf8 too)
+ */
+ qr = pRExC_state->runtime_code_qr;
+ pRExC_state->runtime_code_qr = NULL;
+ assert(RExC_utf8 && SvUTF8(qr));
+ }
+ else {
+ int n = 0;
+ STRLEN s;
+ char *p, *newpat;
+ int newlen = plen + 7; /* allow for "qr''xx\0" extra chars */
+ SV *sv, *qr_ref;
+ dSP;
+
+ /* determine how many extra chars we need for ' and \ escaping */
+ for (s = 0; s < plen; s++) {
+ if (pat[s] == '\'' || pat[s] == '\\')
+ newlen++;
+ }
+
+ Newx(newpat, newlen, char);
+ p = newpat;
+ *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
+
+ for (s = 0; s < plen; s++) {
+ if ( pRExC_state->code_blocks
+ && n < pRExC_state->code_blocks->count
+ && s == pRExC_state->code_blocks->cb[n].start)
+ {
+ /* blank out literal code block so that they aren't
+ * recompiled: eg change from/to:
+ * /(?{xyz})/
+ * /(?=====)/
+ * and
+ * /(??{xyz})/
+ * /(?======)/
+ * and
+ * /(?(?{xyz}))/
+ * /(?(?=====))/
+ */
+ assert(pat[s] == '(');
+ assert(pat[s+1] == '?');
+ *p++ = '(';
+ *p++ = '?';
+ s += 2;
+ while (s < pRExC_state->code_blocks->cb[n].end) {
+ *p++ = '=';
+ s++;
+ }
+ *p++ = ')';
+ n++;
+ continue;
+ }
+ if (pat[s] == '\'' || pat[s] == '\\')
+ *p++ = '\\';
+ *p++ = pat[s];
+ }
+ *p++ = '\'';
+ if (pRExC_state->pm_flags & RXf_PMf_EXTENDED) {
+ *p++ = 'x';
+ if (pRExC_state->pm_flags & RXf_PMf_EXTENDED_MORE) {
+ *p++ = 'x';
+ }
+ }
+ *p++ = '\0';
+ DEBUG_COMPILE_r({
+ Perl_re_printf( aTHX_
+ "%sre-parsing pattern for runtime code:%s %s\n",
+ PL_colors[4], PL_colors[5], newpat);
+ });
+
+ sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
+ Safefree(newpat);
- bool* offset = get_invlist_offset_addr(invlist);
- UV* zero_addr = (UV *) SvPVX(invlist);
+ ENTER;
+ SAVETMPS;
+ save_re_context();
+ PUSHSTACKi(PERLSI_REQUIRE);
+ /* G_RE_REPARSING causes the toker to collapse \\ into \ when
+ * parsing qr''; normally only q'' does this. It also alters
+ * hints handling */
+ eval_sv(sv, G_SCALAR|G_RE_REPARSING);
+ SvREFCNT_dec_NN(sv);
+ SPAGAIN;
+ qr_ref = POPs;
+ PUTBACK;
+ {
+ SV * const errsv = ERRSV;
+ if (SvTRUE_NN(errsv))
+ /* use croak_sv ? */
+ Perl_croak_nocontext("%" SVf, SVfARG(errsv));
+ }
+ assert(SvROK(qr_ref));
+ qr = SvRV(qr_ref);
+ assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
+ /* the leaving below frees the tmp qr_ref.
+ * Give qr a life of its own */
+ SvREFCNT_inc(qr);
+ POPSTACK;
+ FREETMPS;
+ LEAVE;
- PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
+ }
- /* Must be empty */
- assert(! _invlist_len(invlist));
+ if (!RExC_utf8 && SvUTF8(qr)) {
+ /* first time through; the pattern got upgraded; save the
+ * qr for the next time through */
+ assert(!pRExC_state->runtime_code_qr);
+ pRExC_state->runtime_code_qr = qr;
+ return 0;
+ }
- *zero_addr = 0;
- /* 1^1 = 0; 1^0 = 1 */
- *offset = 1 ^ will_have_0;
- return zero_addr + *offset;
-}
+ /* extract any code blocks within the returned qr// */
-STATIC void
-S_invlist_replace_list_destroys_src(pTHX_ SV * dest, SV * src)
-{
- /* Replaces the inversion list in 'dest' with the one from 'src'. It
- * steals the list from 'src', so 'src' is made to have a NULL list. This
- * is similar to what SvSetMagicSV() would do, if it were implemented on
- * inversion lists, though this routine avoids a copy */
-
- const UV src_len = _invlist_len(src);
- const bool src_offset = *get_invlist_offset_addr(src);
- const STRLEN src_byte_len = SvLEN(src);
- char * array = SvPVX(src);
-
- const int oldtainted = TAINT_get;
-
- PERL_ARGS_ASSERT_INVLIST_REPLACE_LIST_DESTROYS_SRC;
-
- assert(is_invlist(src));
- assert(is_invlist(dest));
- assert(! invlist_is_iterating(src));
- assert(SvCUR(src) == 0 || SvCUR(src) < SvLEN(src));
-
- /* Make sure it ends in the right place with a NUL, as our inversion list
- * manipulations aren't careful to keep this true, but sv_usepvn_flags()
- * asserts it */
- array[src_byte_len - 1] = '\0';
-
- TAINT_NOT; /* Otherwise it breaks */
- sv_usepvn_flags(dest,
- (char *) array,
- src_byte_len - 1,
-
- /* This flag is documented to cause a copy to be avoided */
- SV_HAS_TRAILING_NUL);
- TAINT_set(oldtainted);
- SvPV_set(src, 0);
- SvLEN_set(src, 0);
- SvCUR_set(src, 0);
-
- /* Finish up copying over the other fields in an inversion list */
- *get_invlist_offset_addr(dest) = src_offset;
- invlist_set_len(dest, src_len, src_offset);
- *get_invlist_previous_index_addr(dest) = 0;
- invlist_iterfinish(dest);
-}
-PERL_STATIC_INLINE IV*
-S_get_invlist_previous_index_addr(SV* invlist)
-{
- /* Return the address of the IV that is reserved to hold the cached index
- * */
- PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
+ /* merge the main (r1) and run-time (r2) code blocks into one */
+ {
+ RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
+ struct reg_code_block *new_block, *dst;
+ RExC_state_t * const r1 = pRExC_state; /* convenient alias */
+ int i1 = 0, i2 = 0;
+ int r1c, r2c;
- assert(is_invlist(invlist));
+ if (!r2->code_blocks || !r2->code_blocks->count) /* we guessed wrong */
+ {
+ SvREFCNT_dec_NN(qr);
+ return 1;
+ }
- return &(((XINVLIST*) SvANY(invlist))->prev_index);
-}
+ if (!r1->code_blocks)
+ r1->code_blocks = S_alloc_code_blocks(aTHX_ 0);
-PERL_STATIC_INLINE IV
-S_invlist_previous_index(SV* const invlist)
-{
- /* Returns cached index of previous search */
+ r1c = r1->code_blocks->count;
+ r2c = r2->code_blocks->count;
- PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
+ Newx(new_block, r1c + r2c, struct reg_code_block);
- return *get_invlist_previous_index_addr(invlist);
-}
+ dst = new_block;
-PERL_STATIC_INLINE void
-S_invlist_set_previous_index(SV* const invlist, const IV index)
-{
- /* Caches <index> for later retrieval */
+ while (i1 < r1c || i2 < r2c) {
+ struct reg_code_block *src;
+ bool is_qr = 0;
- PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
+ if (i1 == r1c) {
+ src = &r2->code_blocks->cb[i2++];
+ is_qr = 1;
+ }
+ else if (i2 == r2c)
+ src = &r1->code_blocks->cb[i1++];
+ else if ( r1->code_blocks->cb[i1].start
+ < r2->code_blocks->cb[i2].start)
+ {
+ src = &r1->code_blocks->cb[i1++];
+ assert(src->end < r2->code_blocks->cb[i2].start);
+ }
+ else {
+ assert( r1->code_blocks->cb[i1].start
+ > r2->code_blocks->cb[i2].start);
+ src = &r2->code_blocks->cb[i2++];
+ is_qr = 1;
+ assert(src->end < r1->code_blocks->cb[i1].start);
+ }
- assert(index == 0 || index < (int) _invlist_len(invlist));
+ assert(pat[src->start] == '(');
+ assert(pat[src->end] == ')');
+ dst->start = src->start;
+ dst->end = src->end;
+ dst->block = src->block;
+ dst->src_regex = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
+ : src->src_regex;
+ dst++;
+ }
+ r1->code_blocks->count += r2c;
+ Safefree(r1->code_blocks->cb);
+ r1->code_blocks->cb = new_block;
+ }
- *get_invlist_previous_index_addr(invlist) = index;
+ SvREFCNT_dec_NN(qr);
+ return 1;
}
-PERL_STATIC_INLINE void
-S_invlist_trim(SV* invlist)
-{
- /* Free the not currently-being-used space in an inversion list */
-
- /* But don't free up the space needed for the 0 UV that is always at the
- * beginning of the list, nor the trailing NUL */
- const UV min_size = TO_INTERNAL_SIZE(1) + 1;
- PERL_ARGS_ASSERT_INVLIST_TRIM;
+STATIC bool
+S_setup_longest(pTHX_ RExC_state_t *pRExC_state,
+ struct reg_substr_datum *rsd,
+ struct scan_data_substrs *sub,
+ STRLEN longest_length)
+{
+ /* This is the common code for setting up the floating and fixed length
+ * string data extracted from Perl_re_op_compile() below. Returns a boolean
+ * as to whether succeeded or not */
- assert(is_invlist(invlist));
+ I32 t;
+ SSize_t ml;
+ bool eol = cBOOL(sub->flags & SF_BEFORE_EOL);
+ bool meol = cBOOL(sub->flags & SF_BEFORE_MEOL);
- SvPV_renew(invlist, MAX(min_size, SvCUR(invlist) + 1));
-}
+ if (! (longest_length
+ || (eol /* Can't have SEOL and MULTI */
+ && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
+ )
+ /* See comments for join_exact for why REG_UNFOLDED_MULTI_SEEN */
+ || (RExC_seen & REG_UNFOLDED_MULTI_SEEN))
+ {
+ return FALSE;
+ }
-PERL_STATIC_INLINE void
-S_invlist_clear(pTHX_ SV* invlist) /* Empty the inversion list */
-{
- PERL_ARGS_ASSERT_INVLIST_CLEAR;
+ /* copy the information about the longest from the reg_scan_data
+ over to the program. */
+ if (SvUTF8(sub->str)) {
+ rsd->substr = NULL;
+ rsd->utf8_substr = sub->str;
+ } else {
+ rsd->substr = sub->str;
+ rsd->utf8_substr = NULL;
+ }
+ /* end_shift is how many chars that must be matched that
+ follow this item. We calculate it ahead of time as once the
+ lookbehind offset is added in we lose the ability to correctly
+ calculate it.*/
+ ml = sub->minlenp ? *(sub->minlenp) : (SSize_t)longest_length;
+ rsd->end_shift = ml - sub->min_offset
+ - longest_length
+ /* XXX SvTAIL is always false here - did you mean FBMcf_TAIL
+ * intead? - DAPM
+ + (SvTAIL(sub->str) != 0)
+ */
+ + sub->lookbehind;
- assert(is_invlist(invlist));
+ t = (eol/* Can't have SEOL and MULTI */
+ && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
+ fbm_compile(sub->str, t ? FBMcf_TAIL : 0);
- invlist_set_len(invlist, 0, 0);
- invlist_trim(invlist);
+ return TRUE;
}
-#endif /* ifndef PERL_IN_XSUB_RE */
-
-PERL_STATIC_INLINE bool
-S_invlist_is_iterating(SV* const invlist)
+STATIC void
+S_set_regex_pv(pTHX_ RExC_state_t *pRExC_state, REGEXP *Rx)
{
- PERL_ARGS_ASSERT_INVLIST_IS_ITERATING;
+ /* Calculates and sets in the compiled pattern 'Rx' the string to compile,
+ * properly wrapped with the right modifiers */
- return *(get_invlist_iter_addr(invlist)) < (STRLEN) UV_MAX;
-}
+ bool has_p = ((RExC_rx->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
+ bool has_charset = RExC_utf8 || (get_regex_charset(RExC_rx->extflags)
+ != REGEX_DEPENDS_CHARSET);
-#ifndef PERL_IN_XSUB_RE
+ /* The caret is output if there are any defaults: if not all the STD
+ * flags are set, or if no character set specifier is needed */
+ bool has_default =
+ (((RExC_rx->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
+ || ! has_charset);
+ bool has_runon = ((RExC_seen & REG_RUN_ON_COMMENT_SEEN)
+ == REG_RUN_ON_COMMENT_SEEN);
+ U8 reganch = (U8)((RExC_rx->extflags & RXf_PMf_STD_PMMOD)
+ >> RXf_PMf_STD_PMMOD_SHIFT);
+ const char *fptr = STD_PAT_MODS; /*"msixxn"*/
+ char *p;
+ STRLEN pat_len = RExC_precomp_end - RExC_precomp;
-PERL_STATIC_INLINE UV
-S_invlist_max(SV* const invlist)
-{
- /* Returns the maximum number of elements storable in the inversion list's
- * array, without having to realloc() */
+ /* We output all the necessary flags; we never output a minus, as all
+ * those are defaults, so are
+ * covered by the caret */
+ const STRLEN wraplen = pat_len + has_p + has_runon
+ + has_default /* If needs a caret */
+ + PL_bitcount[reganch] /* 1 char for each set standard flag */
- PERL_ARGS_ASSERT_INVLIST_MAX;
+ /* If needs a character set specifier */
+ + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
+ + (sizeof("(?:)") - 1);
- assert(is_invlist(invlist));
+ PERL_ARGS_ASSERT_SET_REGEX_PV;
- /* Assumes worst case, in which the 0 element is not counted in the
- * inversion list, so subtracts 1 for that */
- return SvLEN(invlist) == 0 /* This happens under _new_invlist_C_array */
- ? FROM_INTERNAL_SIZE(SvCUR(invlist)) - 1
- : FROM_INTERNAL_SIZE(SvLEN(invlist)) - 1;
-}
+ /* make sure PL_bitcount bounds not exceeded */
+ STATIC_ASSERT_STMT(sizeof(STD_PAT_MODS) <= 8);
-STATIC void
-S_initialize_invlist_guts(pTHX_ SV* invlist, const Size_t initial_size)
-{
- PERL_ARGS_ASSERT_INITIALIZE_INVLIST_GUTS;
+ p = sv_grow(MUTABLE_SV(Rx), wraplen + 1); /* +1 for the ending NUL */
+ SvPOK_on(Rx);
+ if (RExC_utf8)
+ SvFLAGS(Rx) |= SVf_UTF8;
+ *p++='('; *p++='?';
+
+ /* If a default, cover it using the caret */
+ if (has_default) {
+ *p++= DEFAULT_PAT_MOD;
+ }
+ if (has_charset) {
+ STRLEN len;
+ const char* name;
- /* First 1 is in case the zero element isn't in the list; second 1 is for
- * trailing NUL */
- SvGROW(invlist, TO_INTERNAL_SIZE(initial_size + 1) + 1);
- invlist_set_len(invlist, 0, 0);
+ name = get_regex_charset_name(RExC_rx->extflags, &len);
+ if (strEQ(name, DEPENDS_PAT_MODS)) { /* /d under UTF-8 => /u */
+ assert(RExC_utf8);
+ name = UNICODE_PAT_MODS;
+ len = sizeof(UNICODE_PAT_MODS) - 1;
+ }
+ Copy(name, p, len, char);
+ p += len;
+ }
+ if (has_p)
+ *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
+ {
+ char ch;
+ while((ch = *fptr++)) {
+ if(reganch & 1)
+ *p++ = ch;
+ reganch >>= 1;
+ }
+ }
- /* Force iterinit() to be used to get iteration to work */
- invlist_iterfinish(invlist);
+ *p++ = ':';
+ Copy(RExC_precomp, p, pat_len, char);
+ assert ((RX_WRAPPED(Rx) - p) < 16);
+ RExC_rx->pre_prefix = p - RX_WRAPPED(Rx);
+ p += pat_len;
- *get_invlist_previous_index_addr(invlist) = 0;
- SvPOK_on(invlist); /* This allows B to extract the PV */
+ /* Adding a trailing \n causes this to compile properly:
+ my $R = qr / A B C # D E/x; /($R)/
+ Otherwise the parens are considered part of the comment */
+ if (has_runon)
+ *p++ = '\n';
+ *p++ = ')';
+ *p = 0;
+ SvCUR_set(Rx, p - RX_WRAPPED(Rx));
}
-SV*
-Perl__new_invlist(pTHX_ IV initial_size)
+/*
+ * Perl_re_op_compile - the perl internal RE engine's function to compile a
+ * regular expression into internal code.
+ * The pattern may be passed either as:
+ * a list of SVs (patternp plus pat_count)
+ * a list of OPs (expr)
+ * If both are passed, the SV list is used, but the OP list indicates
+ * which SVs are actually pre-compiled code blocks
+ *
+ * The SVs in the list have magic and qr overloading applied to them (and
+ * the list may be modified in-place with replacement SVs in the latter
+ * case).
+ *
+ * If the pattern hasn't changed from old_re, then old_re will be
+ * returned.
+ *
+ * eng is the current engine. If that engine has an op_comp method, then
+ * handle directly (i.e. we assume that op_comp was us); otherwise, just
+ * do the initial concatenation of arguments and pass on to the external
+ * engine.
+ *
+ * If is_bare_re is not null, set it to a boolean indicating whether the
+ * arg list reduced (after overloading) to a single bare regex which has
+ * been returned (i.e. /$qr/).
+ *
+ * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
+ *
+ * pm_flags contains the PMf_* flags, typically based on those from the
+ * pm_flags field of the related PMOP. Currently we're only interested in
+ * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL, PMf_WILDCARD.
+ *
+ * For many years this code had an initial sizing pass that calculated
+ * (sometimes incorrectly, leading to security holes) the size needed for the
+ * compiled pattern. That was changed by commit
+ * 7c932d07cab18751bfc7515b4320436273a459e2 in 5.29, which reallocs the size, a
+ * node at a time, as parsing goes along. Patches welcome to fix any obsolete
+ * references to this sizing pass.
+ *
+ * Now, an initial crude guess as to the size needed is made, based on the
+ * length of the pattern. Patches welcome to improve that guess. That amount
+ * of space is malloc'd and then immediately freed, and then clawed back node
+ * by node. This design is to minimize, to the extent possible, memory churn
+ * when doing the reallocs.
+ *
+ * A separate parentheses counting pass may be needed in some cases.
+ * (Previously the sizing pass did this.) Patches welcome to reduce the number
+ * of these cases.
+ *
+ * The existence of a sizing pass necessitated design decisions that are no
+ * longer needed. There are potential areas of simplification.
+ *
+ * Beware that the optimization-preparation code in here knows about some
+ * of the structure of the compiled regexp. [I'll say.]
+ */
+
+REGEXP *
+Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
+ OP *expr, const regexp_engine* eng, REGEXP *old_re,
+ bool *is_bare_re, const U32 orig_rx_flags, const U32 pm_flags)
{
+ REGEXP *Rx; /* Capital 'R' means points to a REGEXP */
+ STRLEN plen;
+ char *exp;
+ regnode *scan;
+ I32 flags;
+ SSize_t minlen = 0;
+ U32 rx_flags;
+ SV *pat;
+ SV** new_patternp = patternp;
+
+ /* these are all flags - maybe they should be turned
+ * into a single int with different bit masks */
+ I32 sawlookahead = 0;
+ I32 sawplus = 0;
+ I32 sawopen = 0;
+ I32 sawminmod = 0;
- /* Return a pointer to a newly constructed inversion list, with enough
- * space to store 'initial_size' elements. If that number is negative, a
- * system default is used instead */
+ regex_charset initial_charset = get_regex_charset(orig_rx_flags);
+ bool recompile = 0;
+ bool runtime_code = 0;
+ scan_data_t data;
+ RExC_state_t RExC_state;
+ RExC_state_t * const pRExC_state = &RExC_state;
+#ifdef TRIE_STUDY_OPT
+ /* search for "restudy" in this file for a detailed explanation */
+ int restudied = 0;
+ RExC_state_t copyRExC_state;
+#endif
+ DECLARE_AND_GET_RE_DEBUG_FLAGS;
- SV* new_list;
+ PERL_ARGS_ASSERT_RE_OP_COMPILE;
- if (initial_size < 0) {
- initial_size = 10;
- }
+ DEBUG_r(if (!PL_colorset) reginitcolors());
- new_list = newSV_type(SVt_INVLIST);
- initialize_invlist_guts(new_list, initial_size);
- return new_list;
-}
+ pRExC_state->warn_text = NULL;
+ pRExC_state->unlexed_names = NULL;
+ pRExC_state->code_blocks = NULL;
-SV*
-Perl__new_invlist_C_array(pTHX_ const UV* const list)
-{
- /* Return a pointer to a newly constructed inversion list, initialized to
- * point to <list>, which has to be in the exact correct inversion list
- * form, including internal fields. Thus this is a dangerous routine that
- * should not be used in the wrong hands. The passed in 'list' contains
- * several header fields at the beginning that are not part of the
- * inversion list body proper */
-
- const STRLEN length = (STRLEN) list[0];
- const UV version_id = list[1];
- const bool offset = cBOOL(list[2]);
-#define HEADER_LENGTH 3
- /* If any of the above changes in any way, you must change HEADER_LENGTH
- * (if appropriate) and regenerate INVLIST_VERSION_ID by running
- * perl -E 'say int(rand 2**31-1)'
- */
-#define INVLIST_VERSION_ID 148565664 /* This is a combination of a version and
- data structure type, so that one being
- passed in can be validated to be an
- inversion list of the correct vintage.
- */
+ if (is_bare_re)
+ *is_bare_re = FALSE;
- SV* invlist = newSV_type(SVt_INVLIST);
+ if (expr && (expr->op_type == OP_LIST ||
+ (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
+ /* allocate code_blocks if needed */
+ OP *o;
+ int ncode = 0;
- PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
+ for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o))
+ if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
+ ncode++; /* count of DO blocks */
- if (version_id != INVLIST_VERSION_ID) {
- Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
+ if (ncode)
+ pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_ ncode);
}
- /* The generated array passed in includes header elements that aren't part
- * of the list proper, so start it just after them */
- SvPV_set(invlist, (char *) (list + HEADER_LENGTH));
+ if (!pat_count) {
+ /* compile-time pattern with just OP_CONSTs and DO blocks */
+
+ int n;
+ OP *o;
- SvLEN_set(invlist, 0); /* Means we own the contents, and the system
- shouldn't touch it */
+ /* find how many CONSTs there are */
+ assert(expr);
+ n = 0;
+ if (expr->op_type == OP_CONST)
+ n = 1;
+ else
+ for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
+ if (o->op_type == OP_CONST)
+ n++;
+ }
- *(get_invlist_offset_addr(invlist)) = offset;
+ /* fake up an SV array */
- /* The 'length' passed to us is the physical number of elements in the
- * inversion list. But if there is an offset the logical number is one
- * less than that */
- invlist_set_len(invlist, length - offset, offset);
+ assert(!new_patternp);
+ Newx(new_patternp, n, SV*);
+ SAVEFREEPV(new_patternp);
+ pat_count = n;
- invlist_set_previous_index(invlist, 0);
+ n = 0;
+ if (expr->op_type == OP_CONST)
+ new_patternp[n] = cSVOPx_sv(expr);
+ else
+ for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
+ if (o->op_type == OP_CONST)
+ new_patternp[n++] = cSVOPo_sv;
+ }
- /* Initialize the iteration pointer. */
- invlist_iterfinish(invlist);
+ }
- SvREADONLY_on(invlist);
- SvPOK_on(invlist);
+ DEBUG_PARSE_r(Perl_re_printf( aTHX_
+ "Assembling pattern from %d elements%s\n", pat_count,
+ orig_rx_flags & RXf_SPLIT ? " for split" : ""));
- return invlist;
-}
+ /* set expr to the first arg op */
-STATIC void
-S__append_range_to_invlist(pTHX_ SV* const invlist,
- const UV start, const UV end)
-{
- /* Subject to change or removal. Append the range from 'start' to 'end' at
- * the end of the inversion list. The range must be above any existing
- * ones. */
+ if (pRExC_state->code_blocks && pRExC_state->code_blocks->count
+ && expr->op_type != OP_CONST)
+ {
+ expr = cLISTOPx(expr)->op_first;
+ assert( expr->op_type == OP_PUSHMARK
+ || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK)
+ || expr->op_type == OP_PADRANGE);
+ expr = OpSIBLING(expr);
+ }
- UV* array;
- UV max = invlist_max(invlist);
- UV len = _invlist_len(invlist);
- bool offset;
+ pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count,
+ expr, &recompile, NULL);
- PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
+ /* handle bare (possibly after overloading) regex: foo =~ $re */
+ {
+ SV *re = pat;
+ if (SvROK(re))
+ re = SvRV(re);
+ if (SvTYPE(re) == SVt_REGEXP) {
+ if (is_bare_re)
+ *is_bare_re = TRUE;
+ SvREFCNT_inc(re);
+ DEBUG_PARSE_r(Perl_re_printf( aTHX_
+ "Precompiled pattern%s\n",
+ orig_rx_flags & RXf_SPLIT ? " for split" : ""));
- if (len == 0) { /* Empty lists must be initialized */
- offset = start != 0;
- array = _invlist_array_init(invlist, ! offset);
+ return (REGEXP*)re;
+ }
}
- else {
- /* Here, the existing list is non-empty. The current max entry in the
- * list is generally the first value not in the set, except when the
- * set extends to the end of permissible values, in which case it is
- * the first entry in that final set, and so this call is an attempt to
- * append out-of-order */
-
- UV final_element = len - 1;
- array = invlist_array(invlist);
- if ( array[final_element] > start
- || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
- {
- Perl_croak(aTHX_ "panic: attempting to append to an inversion list, but wasn't at the end of the list, final=%" UVuf ", start=%" UVuf ", match=%c",
- array[final_element], start,
- ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
- }
-
- /* Here, it is a legal append. If the new range begins 1 above the end
- * of the range below it, it is extending the range below it, so the
- * new first value not in the set is one greater than the newly
- * extended range. */
- offset = *get_invlist_offset_addr(invlist);
- if (array[final_element] == start) {
- if (end != UV_MAX) {
- array[final_element] = end + 1;
- }
- else {
- /* But if the end is the maximum representable on the machine,
- * assume that infinity was actually what was meant. Just let
- * the range that this would extend to have no end */
- invlist_set_len(invlist, len - 1, offset);
- }
- return;
- }
+
+ exp = SvPV_nomg(pat, plen);
+
+ if (!eng->op_comp) {
+ if ((SvUTF8(pat) && IN_BYTES)
+ || SvGMAGICAL(pat) || SvAMAGIC(pat))
+ {
+ /* make a temporary copy; either to convert to bytes,
+ * or to avoid repeating get-magic / overloaded stringify */
+ pat = newSVpvn_flags(exp, plen, SVs_TEMP |
+ (IN_BYTES ? 0 : SvUTF8(pat)));
+ }
+ return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
}
- /* Here the new range doesn't extend any existing set. Add it */
+ /* ignore the utf8ness if the pattern is 0 length */
+ RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
+ RExC_uni_semantics = 0;
+ RExC_contains_locale = 0;
+ RExC_strict = cBOOL(pm_flags & RXf_PMf_STRICT);
+ RExC_in_script_run = 0;
+ RExC_study_started = 0;
+ pRExC_state->runtime_code_qr = NULL;
+ RExC_frame_head= NULL;
+ RExC_frame_last= NULL;
+ RExC_frame_count= 0;
+ RExC_latest_warn_offset = 0;
+ RExC_use_BRANCHJ = 0;
+ RExC_warned_WARN_EXPERIMENTAL__VLB = 0;
+ RExC_warned_WARN_EXPERIMENTAL__REGEX_SETS = 0;
+ RExC_logical_total_parens = 0;
+ RExC_total_parens = 0;
+ RExC_logical_to_parno = NULL;
+ RExC_parno_to_logical = NULL;
+ RExC_open_parens = NULL;
+ RExC_close_parens = NULL;
+ RExC_paren_names = NULL;
+ RExC_size = 0;
+ RExC_seen_d_op = FALSE;
+#ifdef DEBUGGING
+ RExC_paren_name_list = NULL;
+#endif
- len += 2; /* Includes an element each for the start and end of range */
+ DEBUG_r({
+ RExC_mysv1= sv_newmortal();
+ RExC_mysv2= sv_newmortal();
+ });
- /* If wll overflow the existing space, extend, which may cause the array to
- * be moved */
- if (max < len) {
- invlist_extend(invlist, len);
+ DEBUG_COMPILE_r({
+ SV *dsv= sv_newmortal();
+ RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, PL_dump_re_max_len);
+ Perl_re_printf( aTHX_ "%sCompiling REx%s %s\n",
+ PL_colors[4], PL_colors[5], s);
+ });
- /* Have to set len here to avoid assert failure in invlist_array() */
- invlist_set_len(invlist, len, offset);
+ /* we jump here if we have to recompile, e.g., from upgrading the pattern
+ * to utf8 */
- array = invlist_array(invlist);
- }
- else {
- invlist_set_len(invlist, len, offset);
- }
+ if ((pm_flags & PMf_USE_RE_EVAL)
+ /* this second condition covers the non-regex literal case,
+ * i.e. $foo =~ '(?{})'. */
+ || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
+ )
+ runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
- /* The next item on the list starts the range, the one after that is
- * one past the new range. */
- array[len - 2] = start;
- if (end != UV_MAX) {
- array[len - 1] = end + 1;
- }
- else {
- /* But if the end is the maximum representable on the machine, just let
- * the range have no end */
- invlist_set_len(invlist, len - 1, offset);
+ redo_parse:
+ /* return old regex if pattern hasn't changed */
+ /* XXX: note in the below we have to check the flags as well as the
+ * pattern.
+ *
+ * Things get a touch tricky as we have to compare the utf8 flag
+ * independently from the compile flags. */
+
+ if ( old_re
+ && !recompile
+ && cBOOL(RX_UTF8(old_re)) == cBOOL(RExC_utf8)
+ && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
+ && RX_PRELEN(old_re) == plen
+ && memEQ(RX_PRECOMP(old_re), exp, plen)
+ && !runtime_code /* with runtime code, always recompile */ )
+ {
+ DEBUG_COMPILE_r({
+ SV *dsv= sv_newmortal();
+ RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, PL_dump_re_max_len);
+ Perl_re_printf( aTHX_ "%sSkipping recompilation of unchanged REx%s %s\n",
+ PL_colors[4], PL_colors[5], s);
+ });
+ return old_re;
}
-}
-SSize_t
-Perl__invlist_search(SV* const invlist, const UV cp)
-{
- /* Searches the inversion list for the entry that contains the input code
- * point <cp>. If <cp> is not in the list, -1 is returned. Otherwise, the
- * return value is the index into the list's array of the range that
- * contains <cp>, that is, 'i' such that
- * array[i] <= cp < array[i+1]
- */
+ /* Allocate the pattern's SV */
+ RExC_rx_sv = Rx = (REGEXP*) newSV_type(SVt_REGEXP);
+ RExC_rx = ReANY(Rx);
+ if ( RExC_rx == NULL )
+ FAIL("Regexp out of space");
- IV low = 0;
- IV mid;
- IV high = _invlist_len(invlist);
- const IV highest_element = high - 1;
- const UV* array;
+ rx_flags = orig_rx_flags;
- PERL_ARGS_ASSERT__INVLIST_SEARCH;
+ if ( toUSE_UNI_CHARSET_NOT_DEPENDS
+ && initial_charset == REGEX_DEPENDS_CHARSET)
+ {
- /* If list is empty, return failure. */
- if (high == 0) {
- return -1;
+ /* Set to use unicode semantics if the pattern is in utf8 and has the
+ * 'depends' charset specified, as it means unicode when utf8 */
+ set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
+ RExC_uni_semantics = 1;
}
- /* (We can't get the array unless we know the list is non-empty) */
- array = invlist_array(invlist);
+ RExC_pm_flags = pm_flags;
- mid = invlist_previous_index(invlist);
- assert(mid >=0);
- if (mid > highest_element) {
- mid = highest_element;
- }
+ if (runtime_code) {
+ assert(TAINTING_get || !TAINT_get);
+ if (TAINT_get)
+ Perl_croak(aTHX_ "Eval-group in insecure regular expression");
- /* <mid> contains the cache of the result of the previous call to this
- * function (0 the first time). See if this call is for the same result,
- * or if it is for mid-1. This is under the theory that calls to this
- * function will often be for related code points that are near each other.
- * And benchmarks show that caching gives better results. We also test
- * here if the code point is within the bounds of the list. These tests
- * replace others that would have had to be made anyway to make sure that
- * the array bounds were not exceeded, and these give us extra information
- * at the same time */
- if (cp >= array[mid]) {
- if (cp >= array[highest_element]) {
- return highest_element;
- }
-
- /* Here, array[mid] <= cp < array[highest_element]. This means that
- * the final element is not the answer, so can exclude it; it also
- * means that <mid> is not the final element, so can refer to 'mid + 1'
- * safely */
- if (cp < array[mid + 1]) {
- return mid;
- }
- high--;
- low = mid + 1;
- }
- else { /* cp < aray[mid] */
- if (cp < array[0]) { /* Fail if outside the array */
- return -1;
- }
- high = mid;
- if (cp >= array[mid - 1]) {
- goto found_entry;
+ if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
+ /* whoops, we have a non-utf8 pattern, whilst run-time code
+ * got compiled as utf8. Try again with a utf8 pattern */
+ S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
+ pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
+ goto redo_parse;
}
}
+ assert(!pRExC_state->runtime_code_qr);
- /* Binary search. What we are looking for is <i> such that
- * array[i] <= cp < array[i+1]
- * The loop below converges on the i+1. Note that there may not be an
- * (i+1)th element in the array, and things work nonetheless */
- while (low < high) {
- mid = (low + high) / 2;
- assert(mid <= highest_element);
- if (array[mid] <= cp) { /* cp >= array[mid] */
- low = mid + 1;
-
- /* We could do this extra test to exit the loop early.
- if (cp < array[low]) {
- return mid;
- }
- */
- }
- else { /* cp < array[mid] */
- high = mid;
- }
- }
+ RExC_sawback = 0;
- found_entry:
- high--;
- invlist_set_previous_index(invlist, high);
- return high;
-}
+ RExC_seen = 0;
+ RExC_maxlen = 0;
+ RExC_in_lookaround = 0;
+ RExC_seen_zerolen = *exp == '^' ? -1 : 0;
+ RExC_recode_x_to_native = 0;
+ RExC_in_multi_char_class = 0;
-void
-Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
- const bool complement_b, SV** output)
-{
- /* Take the union of two inversion lists and point '*output' to it. On
- * input, '*output' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
- * even 'a' or 'b'). If to an inversion list, the contents of the original
- * list will be replaced by the union. The first list, 'a', may be
- * NULL, in which case a copy of the second list is placed in '*output'.
- * If 'complement_b' is TRUE, the union is taken of the complement
- * (inversion) of 'b' instead of b itself.
- *
- * The basis for this comes from "Unicode Demystified" Chapter 13 by
- * Richard Gillam, published by Addison-Wesley, and explained at some
- * length there. The preface says to incorporate its examples into your
- * code at your own risk.
- *
- * The algorithm is like a merge sort. */
-
- const UV* array_a; /* a's array */
- const UV* array_b;
- UV len_a; /* length of a's array */
- UV len_b;
-
- SV* u; /* the resulting union */
- UV* array_u;
- UV len_u = 0;
-
- UV i_a = 0; /* current index into a's array */
- UV i_b = 0;
- UV i_u = 0;
-
- /* running count, as explained in the algorithm source book; items are
- * stopped accumulating and are output when the count changes to/from 0.
- * The count is incremented when we start a range that's in an input's set,
- * and decremented when we start a range that's not in a set. So this
- * variable can be 0, 1, or 2. When it is 0 neither input is in their set,
- * and hence nothing goes into the union; 1, just one of the inputs is in
- * its set (and its current range gets added to the union); and 2 when both
- * inputs are in their sets. */
- UV count = 0;
-
- PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
- assert(a != b);
- assert(*output == NULL || is_invlist(*output));
-
- len_b = _invlist_len(b);
- if (len_b == 0) {
-
- /* Here, 'b' is empty, hence it's complement is all possible code
- * points. So if the union includes the complement of 'b', it includes
- * everything, and we need not even look at 'a'. It's easiest to
- * create a new inversion list that matches everything. */
- if (complement_b) {
- SV* everything = _add_range_to_invlist(NULL, 0, UV_MAX);
-
- if (*output == NULL) { /* If the output didn't exist, just point it
- at the new list */
- *output = everything;
- }
- else { /* Otherwise, replace its contents with the new list */
- invlist_replace_list_destroys_src(*output, everything);
- SvREFCNT_dec_NN(everything);
- }
+ RExC_start = RExC_copy_start_in_constructed = RExC_copy_start_in_input = RExC_precomp = exp;
+ RExC_precomp_end = RExC_end = exp + plen;
+ RExC_nestroot = 0;
+ RExC_whilem_seen = 0;
+ RExC_end_op = NULL;
+ RExC_recurse = NULL;
+ RExC_study_chunk_recursed = NULL;
+ RExC_study_chunk_recursed_bytes= 0;
+ RExC_recurse_count = 0;
+ RExC_sets_depth = 0;
+ pRExC_state->code_index = 0;
- return;
- }
+ /* Initialize the string in the compiled pattern. This is so that there is
+ * something to output if necessary */
+ set_regex_pv(pRExC_state, Rx);
- /* Here, we don't want the complement of 'b', and since 'b' is empty,
- * the union will come entirely from 'a'. If 'a' is NULL or empty, the
- * output will be empty */
+ DEBUG_PARSE_r({
+ Perl_re_printf( aTHX_
+ "Starting parse and generation\n");
+ RExC_lastnum=0;
+ RExC_lastparse=NULL;
+ });
- if (a == NULL || _invlist_len(a) == 0) {
- if (*output == NULL) {
- *output = _new_invlist(0);
- }
- else {
- invlist_clear(*output);
- }
- return;
- }
+ /* Allocate space and zero-initialize. Note, the two step process
+ of zeroing when in debug mode, thus anything assigned has to
+ happen after that */
+ if (! RExC_size) {
- /* Here, 'a' is not empty, but 'b' is, so 'a' entirely determines the
- * union. We can just return a copy of 'a' if '*output' doesn't point
- * to an existing list */
- if (*output == NULL) {
- *output = invlist_clone(a, NULL);
- return;
- }
+ /* On the first pass of the parse, we guess how big this will be. Then
+ * we grow in one operation to that amount and then give it back. As
+ * we go along, we re-allocate what we need.
+ *
+ * XXX Currently the guess is essentially that the pattern will be an
+ * EXACT node with one byte input, one byte output. This is crude, and
+ * better heuristics are welcome.
+ *
+ * On any subsequent passes, we guess what we actually computed in the
+ * latest earlier pass. Such a pass probably didn't complete so is
+ * missing stuff. We could improve those guesses by knowing where the
+ * parse stopped, and use the length so far plus apply the above
+ * assumption to what's left. */
+ RExC_size = STR_SZ(RExC_end - RExC_start);
+ }
- /* If the output is to overwrite 'a', we have a no-op, as it's
- * already in 'a' */
- if (*output == a) {
- return;
- }
+ Newxc(RExC_rxi, sizeof(regexp_internal) + RExC_size, char, regexp_internal);
+ if ( RExC_rxi == NULL )
+ FAIL("Regexp out of space");
+
+ Zero(RExC_rxi, sizeof(regexp_internal) + RExC_size, char);
+ RXi_SET( RExC_rx, RExC_rxi );
- /* Here, '*output' is to be overwritten by 'a' */
- u = invlist_clone(a, NULL);
- invlist_replace_list_destroys_src(*output, u);
- SvREFCNT_dec_NN(u);
+ /* We start from 0 (over from 0 in the case this is a reparse. The first
+ * node parsed will give back any excess memory we have allocated so far).
+ * */
+ RExC_size = 0;
- return;
+ /* non-zero initialization begins here */
+ RExC_rx->engine= eng;
+ RExC_rx->extflags = rx_flags;
+ RXp_COMPFLAGS(RExC_rx) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
+
+ if (pm_flags & PMf_IS_QR) {
+ RExC_rxi->code_blocks = pRExC_state->code_blocks;
+ if (RExC_rxi->code_blocks) {
+ RExC_rxi->code_blocks->refcnt++;
+ }
}
- /* Here 'b' is not empty. See about 'a' */
+ RExC_rx->intflags = 0;
+
+ RExC_flags = rx_flags; /* don't let top level (?i) bleed */
+ RExC_parse_set(exp);
+
+ /* This NUL is guaranteed because the pattern comes from an SV*, and the sv
+ * code makes sure the final byte is an uncounted NUL. But should this
+ * ever not be the case, lots of things could read beyond the end of the
+ * buffer: loops like
+ * while(isFOO(*RExC_parse)) RExC_parse_inc_by(1);
+ * strchr(RExC_parse, "foo");
+ * etc. So it is worth noting. */
+ assert(*RExC_end == '\0');
- if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
+ RExC_naughty = 0;
+ RExC_npar = 1;
+ RExC_logical_npar = 1;
+ RExC_parens_buf_size = 0;
+ RExC_emit_start = RExC_rxi->program;
+ pRExC_state->code_index = 0;
- /* Here, 'a' is empty (and b is not). That means the union will come
- * entirely from 'b'. If '*output' is NULL, we can directly return a
- * clone of 'b'. Otherwise, we replace the contents of '*output' with
- * the clone */
+ *((char*) RExC_emit_start) = (char) REG_MAGIC;
+ RExC_emit = NODE_STEP_REGNODE;
- SV ** dest = (*output == NULL) ? output : &u;
- *dest = invlist_clone(b, NULL);
- if (complement_b) {
- _invlist_invert(*dest);
- }
+ /* Do the parse */
+ if (reg(pRExC_state, 0, &flags, 1)) {
- if (dest == &u) {
- invlist_replace_list_destroys_src(*output, u);
- SvREFCNT_dec_NN(u);
+ /* Success!, But we may need to redo the parse knowing how many parens
+ * there actually are */
+ if (IN_PARENS_PASS) {
+ flags |= RESTART_PARSE;
}
- return;
+ /* We have that number in RExC_npar */
+ RExC_total_parens = RExC_npar;
+ RExC_logical_total_parens = RExC_logical_npar;
+ }
+ else if (! MUST_RESTART(flags)) {
+ ReREFCNT_dec(Rx);
+ Perl_croak(aTHX_ "panic: reg returned failure to re_op_compile, flags=%#" UVxf, (UV) flags);
}
- /* Here both lists exist and are non-empty */
- array_a = invlist_array(a);
- array_b = invlist_array(b);
+ /* Here, we either have success, or we have to redo the parse for some reason */
+ if (MUST_RESTART(flags)) {
- /* If are to take the union of 'a' with the complement of b, set it
- * up so are looking at b's complement. */
- if (complement_b) {
+ /* It's possible to write a regexp in ascii that represents Unicode
+ codepoints outside of the byte range, such as via \x{100}. If we
+ detect such a sequence we have to convert the entire pattern to utf8
+ and then recompile, as our sizing calculation will have been based
+ on 1 byte == 1 character, but we will need to use utf8 to encode
+ at least some part of the pattern, and therefore must convert the whole
+ thing.
+ -- dmq */
+ if (flags & NEED_UTF8) {
- /* To complement, we invert: if the first element is 0, remove it. To
- * do this, we just pretend the array starts one later */
- if (array_b[0] == 0) {
- array_b++;
- len_b--;
+ /* We have stored the offset of the final warning output so far.
+ * That must be adjusted. Any variant characters between the start
+ * of the pattern and this warning count for 2 bytes in the final,
+ * so just add them again */
+ if (UNLIKELY(RExC_latest_warn_offset > 0)) {
+ RExC_latest_warn_offset +=
+ variant_under_utf8_count((U8 *) exp, (U8 *) exp
+ + RExC_latest_warn_offset);
+ }
+ S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
+ pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
+ DEBUG_PARSE_r(Perl_re_printf( aTHX_ "Need to redo parse after upgrade\n"));
}
else {
-
- /* But if the first element is not zero, we pretend the list starts
- * at the 0 that is always stored immediately before the array. */
- array_b--;
- len_b++;
+ DEBUG_PARSE_r(Perl_re_printf( aTHX_ "Need to redo parse\n"));
}
- }
-
- /* Size the union for the worst case: that the sets are completely
- * disjoint */
- u = _new_invlist(len_a + len_b);
-
- /* Will contain U+0000 if either component does */
- array_u = _invlist_array_init(u, ( len_a > 0 && array_a[0] == 0)
- || (len_b > 0 && array_b[0] == 0));
-
- /* Go through each input list item by item, stopping when have exhausted
- * one of them */
- while (i_a < len_a && i_b < len_b) {
- UV cp; /* The element to potentially add to the union's array */
- bool cp_in_set; /* is it in the input list's set or not */
-
- /* We need to take one or the other of the two inputs for the union.
- * Since we are merging two sorted lists, we take the smaller of the
- * next items. In case of a tie, we take first the one that is in its
- * set. If we first took the one not in its set, it would decrement
- * the count, possibly to 0 which would cause it to be output as ending
- * the range, and the next time through we would take the same number,
- * and output it again as beginning the next range. By doing it the
- * opposite way, there is no possibility that the count will be
- * momentarily decremented to 0, and thus the two adjoining ranges will
- * be seamlessly merged. (In a tie and both are in the set or both not
- * in the set, it doesn't matter which we take first.) */
- if ( array_a[i_a] < array_b[i_b]
- || ( array_a[i_a] == array_b[i_b]
- && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
- {
- cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
- cp = array_a[i_a++];
- }
- else {
- cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
- cp = array_b[i_b++];
- }
-
- /* Here, have chosen which of the two inputs to look at. Only output
- * if the running count changes to/from 0, which marks the
- * beginning/end of a range that's in the set */
- if (cp_in_set) {
- if (count == 0) {
- array_u[i_u++] = cp;
- }
- count++;
- }
- else {
- count--;
- if (count == 0) {
- array_u[i_u++] = cp;
- }
- }
- }
-
- /* The loop above increments the index into exactly one of the input lists
- * each iteration, and ends when either index gets to its list end. That
- * means the other index is lower than its end, and so something is
- * remaining in that one. We decrement 'count', as explained below, if
- * that list is in its set. (i_a and i_b each currently index the element
- * beyond the one we care about.) */
- if ( (i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
- || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
- {
- count--;
- }
+ if (ALL_PARENS_COUNTED) {
+ /* Make enough room for all the known parens, and zero it */
+ Renew(RExC_open_parens, RExC_total_parens, regnode_offset);
+ Zero(RExC_open_parens, RExC_total_parens, regnode_offset);
+ RExC_open_parens[0] = 1; /* +1 for REG_MAGIC */
- /* Above we decremented 'count' if the list that had unexamined elements in
- * it was in its set. This has made it so that 'count' being non-zero
- * means there isn't anything left to output; and 'count' equal to 0 means
- * that what is left to output is precisely that which is left in the
- * non-exhausted input list.
- *
- * To see why, note first that the exhausted input obviously has nothing
- * left to add to the union. If it was in its set at its end, that means
- * the set extends from here to the platform's infinity, and hence so does
- * the union and the non-exhausted set is irrelevant. The exhausted set
- * also contributed 1 to 'count'. If 'count' was 2, it got decremented to
- * 1, but if it was 1, the non-exhausted set wasn't in its set, and so
- * 'count' remains at 1. This is consistent with the decremented 'count'
- * != 0 meaning there's nothing left to add to the union.
- *
- * But if the exhausted input wasn't in its set, it contributed 0 to
- * 'count', and the rest of the union will be whatever the other input is.
- * If 'count' was 0, neither list was in its set, and 'count' remains 0;
- * otherwise it gets decremented to 0. This is consistent with 'count'
- * == 0 meaning the remainder of the union is whatever is left in the
- * non-exhausted list. */
- if (count != 0) {
- len_u = i_u;
- }
- else {
- IV copy_count = len_a - i_a;
- if (copy_count > 0) { /* The non-exhausted input is 'a' */
- Copy(array_a + i_a, array_u + i_u, copy_count, UV);
+ Renew(RExC_close_parens, RExC_total_parens, regnode_offset);
+ Zero(RExC_close_parens, RExC_total_parens, regnode_offset);
+ /* we do NOT reinitialize RExC_logical_to_parno and
+ * RExC_parno_to_logical here. We need their data on the second
+ * pass */
}
- else { /* The non-exhausted input is b */
- copy_count = len_b - i_b;
- Copy(array_b + i_b, array_u + i_u, copy_count, UV);
+ else { /* Parse did not complete. Reinitialize the parentheses
+ structures */
+ RExC_total_parens = 0;
+ if (RExC_open_parens) {
+ Safefree(RExC_open_parens);
+ RExC_open_parens = NULL;
+ }
+ if (RExC_close_parens) {
+ Safefree(RExC_close_parens);
+ RExC_close_parens = NULL;
+ }
+ if (RExC_logical_to_parno) {
+ Safefree(RExC_logical_to_parno);
+ RExC_logical_to_parno = NULL;
+ }
+ if (RExC_parno_to_logical) {
+ Safefree(RExC_parno_to_logical);
+ RExC_parno_to_logical = NULL;
+ }
}
- len_u = i_u + copy_count;
- }
- /* Set the result to the final length, which can change the pointer to
- * array_u, so re-find it. (Note that it is unlikely that this will
- * change, as we are shrinking the space, not enlarging it) */
- if (len_u != _invlist_len(u)) {
- invlist_set_len(u, len_u, *get_invlist_offset_addr(u));
- invlist_trim(u);
- array_u = invlist_array(u);
- }
+ /* Clean up what we did in this parse */
+ SvREFCNT_dec_NN(RExC_rx_sv);
- if (*output == NULL) { /* Simply return the new inversion list */
- *output = u;
- }
- else {
- /* Otherwise, overwrite the inversion list that was in '*output'. We
- * could instead free '*output', and then set it to 'u', but experience
- * has shown [perl #127392] that if the input is a mortal, we can get a
- * huge build-up of these during regex compilation before they get
- * freed. */
- invlist_replace_list_destroys_src(*output, u);
- SvREFCNT_dec_NN(u);
+ goto redo_parse;
}
- return;
-}
-
-void
-Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
- const bool complement_b, SV** i)
-{
- /* Take the intersection of two inversion lists and point '*i' to it. On
- * input, '*i' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
- * even 'a' or 'b'). If to an inversion list, the contents of the original
- * list will be replaced by the intersection. The first list, 'a', may be
- * NULL, in which case '*i' will be an empty list. If 'complement_b' is
- * TRUE, the result will be the intersection of 'a' and the complement (or
- * inversion) of 'b' instead of 'b' directly.
- *
- * The basis for this comes from "Unicode Demystified" Chapter 13 by
- * Richard Gillam, published by Addison-Wesley, and explained at some
- * length there. The preface says to incorporate its examples into your
- * code at your own risk. In fact, it had bugs
- *
- * The algorithm is like a merge sort, and is essentially the same as the
- * union above
- */
+ /* Here, we have successfully parsed and generated the pattern's program
+ * for the regex engine. We are ready to finish things up and look for
+ * optimizations. */
- const UV* array_a; /* a's array */
- const UV* array_b;
- UV len_a; /* length of a's array */
- UV len_b;
-
- SV* r; /* the resulting intersection */
- UV* array_r;
- UV len_r = 0;
-
- UV i_a = 0; /* current index into a's array */
- UV i_b = 0;
- UV i_r = 0;
-
- /* running count of how many of the two inputs are postitioned at ranges
- * that are in their sets. As explained in the algorithm source book,
- * items are stopped accumulating and are output when the count changes
- * to/from 2. The count is incremented when we start a range that's in an
- * input's set, and decremented when we start a range that's not in a set.
- * Only when it is 2 are we in the intersection. */
- UV count = 0;
-
- PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
- assert(a != b);
- assert(*i == NULL || is_invlist(*i));
-
- /* Special case if either one is empty */
- len_a = (a == NULL) ? 0 : _invlist_len(a);
- if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
- if (len_a != 0 && complement_b) {
-
- /* Here, 'a' is not empty, therefore from the enclosing 'if', 'b'
- * must be empty. Here, also we are using 'b's complement, which
- * hence must be every possible code point. Thus the intersection
- * is simply 'a'. */
-
- if (*i == a) { /* No-op */
- return;
- }
+ /* Update the string to compile, with correct modifiers, etc */
+ set_regex_pv(pRExC_state, Rx);
- if (*i == NULL) {
- *i = invlist_clone(a, NULL);
- return;
- }
+ RExC_rx->nparens = RExC_total_parens - 1;
+ RExC_rx->logical_nparens = RExC_logical_total_parens - 1;
- r = invlist_clone(a, NULL);
- invlist_replace_list_destroys_src(*i, r);
- SvREFCNT_dec_NN(r);
- return;
- }
+ /* Uses the upper 4 bits of the FLAGS field, so keep within that size */
+ if (RExC_whilem_seen > 15)
+ RExC_whilem_seen = 15;
- /* Here, 'a' or 'b' is empty and not using the complement of 'b'. The
- * intersection must be empty */
- if (*i == NULL) {
- *i = _new_invlist(0);
- return;
- }
+ DEBUG_PARSE_r({
+ Perl_re_printf( aTHX_
+ "Required size %" IVdf " nodes\n", (IV)RExC_size);
+ RExC_lastnum=0;
+ RExC_lastparse=NULL;
+ });
- invlist_clear(*i);
- return;
- }
+ SetProgLen(RExC_rxi,RExC_size);
- /* Here both lists exist and are non-empty */
- array_a = invlist_array(a);
- array_b = invlist_array(b);
+ DEBUG_DUMP_PRE_OPTIMIZE_r({
+ SV * const sv = sv_newmortal();
+ RXi_GET_DECL(RExC_rx, ri);
+ DEBUG_RExC_seen();
+ Perl_re_printf( aTHX_ "Program before optimization:\n");
- /* If are to take the intersection of 'a' with the complement of b, set it
- * up so are looking at b's complement. */
- if (complement_b) {
+ (void)dumpuntil(RExC_rx, ri->program, ri->program + 1, NULL, NULL,
+ sv, 0, 0);
+ });
- /* To complement, we invert: if the first element is 0, remove it. To
- * do this, we just pretend the array starts one later */
- if (array_b[0] == 0) {
- array_b++;
- len_b--;
- }
- else {
+ DEBUG_OPTIMISE_r(
+ Perl_re_printf( aTHX_ "Starting post parse optimization\n");
+ );
- /* But if the first element is not zero, we pretend the list starts
- * at the 0 that is always stored immediately before the array. */
- array_b--;
- len_b++;
- }
+ /* XXXX To minimize changes to RE engine we always allocate
+ 3-units-long substrs field. */
+ Newx(RExC_rx->substrs, 1, struct reg_substr_data);
+ if (RExC_recurse_count) {
+ Newx(RExC_recurse, RExC_recurse_count, regnode *);
+ SAVEFREEPV(RExC_recurse);
}
- /* Size the intersection for the worst case: that the intersection ends up
- * fragmenting everything to be completely disjoint */
- r= _new_invlist(len_a + len_b);
-
- /* Will contain U+0000 iff both components do */
- array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
- && len_b > 0 && array_b[0] == 0);
-
- /* Go through each list item by item, stopping when have exhausted one of
- * them */
- while (i_a < len_a && i_b < len_b) {
- UV cp; /* The element to potentially add to the intersection's
- array */
- bool cp_in_set; /* Is it in the input list's set or not */
-
- /* We need to take one or the other of the two inputs for the
- * intersection. Since we are merging two sorted lists, we take the
- * smaller of the next items. In case of a tie, we take first the one
- * that is not in its set (a difference from the union algorithm). If
- * we first took the one in its set, it would increment the count,
- * possibly to 2 which would cause it to be output as starting a range
- * in the intersection, and the next time through we would take that
- * same number, and output it again as ending the set. By doing the
- * opposite of this, there is no possibility that the count will be
- * momentarily incremented to 2. (In a tie and both are in the set or
- * both not in the set, it doesn't matter which we take first.) */
- if ( array_a[i_a] < array_b[i_b]
- || ( array_a[i_a] == array_b[i_b]
- && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
- {
- cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
- cp = array_a[i_a++];
- }
- else {
- cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
- cp= array_b[i_b++];
- }
-
- /* Here, have chosen which of the two inputs to look at. Only output
- * if the running count changes to/from 2, which marks the
- * beginning/end of a range that's in the intersection */
- if (cp_in_set) {
- count++;
- if (count == 2) {
- array_r[i_r++] = cp;
- }
- }
- else {
- if (count == 2) {
- array_r[i_r++] = cp;
- }
- count--;
- }
-
+ if (RExC_seen & REG_RECURSE_SEEN) {
+ /* Note, RExC_total_parens is 1 + the number of parens in a pattern.
+ * So its 1 if there are no parens. */
+ RExC_study_chunk_recursed_bytes= (RExC_total_parens >> 3) +
+ ((RExC_total_parens & 0x07) != 0);
+ Newx(RExC_study_chunk_recursed,
+ RExC_study_chunk_recursed_bytes * RExC_total_parens, U8);
+ SAVEFREEPV(RExC_study_chunk_recursed);
}
- /* The loop above increments the index into exactly one of the input lists
- * each iteration, and ends when either index gets to its list end. That
- * means the other index is lower than its end, and so something is
- * remaining in that one. We increment 'count', as explained below, if the
- * exhausted list was in its set. (i_a and i_b each currently index the
- * element beyond the one we care about.) */
- if ( (i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
- || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
- {
- count++;
+ reStudy:
+ RExC_rx->minlen = minlen = sawlookahead = sawplus = sawopen = sawminmod = 0;
+ DEBUG_r(
+ RExC_study_chunk_recursed_count= 0;
+ );
+ Zero(RExC_rx->substrs, 1, struct reg_substr_data);
+ if (RExC_study_chunk_recursed) {
+ Zero(RExC_study_chunk_recursed,
+ RExC_study_chunk_recursed_bytes * RExC_total_parens, U8);
}
- /* Above we incremented 'count' if the exhausted list was in its set. This
- * has made it so that 'count' being below 2 means there is nothing left to
- * output; otheriwse what's left to add to the intersection is precisely
- * that which is left in the non-exhausted input list.
- *
- * To see why, note first that the exhausted input obviously has nothing
- * left to affect the intersection. If it was in its set at its end, that
- * means the set extends from here to the platform's infinity, and hence
- * anything in the non-exhausted's list will be in the intersection, and
- * anything not in it won't be. Hence, the rest of the intersection is
- * precisely what's in the non-exhausted list The exhausted set also
- * contributed 1 to 'count', meaning 'count' was at least 1. Incrementing
- * it means 'count' is now at least 2. This is consistent with the
- * incremented 'count' being >= 2 means to add the non-exhausted list to
- * the intersection.
- *
- * But if the exhausted input wasn't in its set, it contributed 0 to
- * 'count', and the intersection can't include anything further; the
- * non-exhausted set is irrelevant. 'count' was at most 1, and doesn't get
- * incremented. This is consistent with 'count' being < 2 meaning nothing
- * further to add to the intersection. */
- if (count < 2) { /* Nothing left to put in the intersection. */
- len_r = i_r;
- }
- else { /* copy the non-exhausted list, unchanged. */
- IV copy_count = len_a - i_a;
- if (copy_count > 0) { /* a is the one with stuff left */
- Copy(array_a + i_a, array_r + i_r, copy_count, UV);
- }
- else { /* b is the one with stuff left */
- copy_count = len_b - i_b;
- Copy(array_b + i_b, array_r + i_r, copy_count, UV);
- }
- len_r = i_r + copy_count;
- }
- /* Set the result to the final length, which can change the pointer to
- * array_r, so re-find it. (Note that it is unlikely that this will
- * change, as we are shrinking the space, not enlarging it) */
- if (len_r != _invlist_len(r)) {
- invlist_set_len(r, len_r, *get_invlist_offset_addr(r));
- invlist_trim(r);
- array_r = invlist_array(r);
- }
+#ifdef TRIE_STUDY_OPT
+ /* search for "restudy" in this file for a detailed explanation */
+ if (!restudied) {
+ StructCopy(&zero_scan_data, &data, scan_data_t);
+ copyRExC_state = RExC_state;
+ } else {
+ U32 seen=RExC_seen;
+ DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "Restudying\n"));
- if (*i == NULL) { /* Simply return the calculated intersection */
- *i = r;
- }
- else { /* Otherwise, replace the existing inversion list in '*i'. We could
- instead free '*i', and then set it to 'r', but experience has
- shown [perl #127392] that if the input is a mortal, we can get a
- huge build-up of these during regex compilation before they get
- freed. */
- if (len_r) {
- invlist_replace_list_destroys_src(*i, r);
- }
- else {
- invlist_clear(*i);
- }
- SvREFCNT_dec_NN(r);
+ RExC_state = copyRExC_state;
+ if (seen & REG_TOP_LEVEL_BRANCHES_SEEN)
+ RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
+ else
+ RExC_seen &= ~REG_TOP_LEVEL_BRANCHES_SEEN;
+ StructCopy(&zero_scan_data, &data, scan_data_t);
}
+#else
+ StructCopy(&zero_scan_data, &data, scan_data_t);
+#endif
- return;
-}
-
-SV*
-Perl__add_range_to_invlist(pTHX_ SV* invlist, UV start, UV end)
-{
- /* Add the range from 'start' to 'end' inclusive to the inversion list's
- * set. A pointer to the inversion list is returned. This may actually be
- * a new list, in which case the passed in one has been destroyed. The
- * passed-in inversion list can be NULL, in which case a new one is created
- * with just the one range in it. The new list is not necessarily
- * NUL-terminated. Space is not freed if the inversion list shrinks as a
- * result of this function. The gain would not be large, and in many
- * cases, this is called multiple times on a single inversion list, so
- * anything freed may almost immediately be needed again.
- *
- * This used to mostly call the 'union' routine, but that is much more
- * heavyweight than really needed for a single range addition */
-
- UV* array; /* The array implementing the inversion list */
- UV len; /* How many elements in 'array' */
- SSize_t i_s; /* index into the invlist array where 'start'
- should go */
- SSize_t i_e = 0; /* And the index where 'end' should go */
- UV cur_highest; /* The highest code point in the inversion list
- upon entry to this function */
-
- /* This range becomes the whole inversion list if none already existed */
- if (invlist == NULL) {
- invlist = _new_invlist(2);
- _append_range_to_invlist(invlist, start, end);
- return invlist;
- }
+ /* Dig out information for optimizations. */
+ RExC_rx->extflags = RExC_flags; /* was pm_op */
+ /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
- /* Likewise, if the inversion list is currently empty */
- len = _invlist_len(invlist);
- if (len == 0) {
- _append_range_to_invlist(invlist, start, end);
- return invlist;
- }
+ if (UTF)
+ SvUTF8_on(Rx); /* Unicode in it? */
+ RExC_rxi->regstclass = NULL;
+ if (RExC_naughty >= TOO_NAUGHTY) /* Probably an expensive pattern. */
+ RExC_rx->intflags |= PREGf_NAUGHTY;
+ scan = RExC_rxi->program + 1; /* First BRANCH. */
- /* Starting here, we have to know the internals of the list */
- array = invlist_array(invlist);
+ /* testing for BRANCH here tells us whether there is "must appear"
+ data in the pattern. If there is then we can use it for optimisations */
+ if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)) { /* Only one top-level choice.
+ */
+ SSize_t fake_deltap;
+ STRLEN longest_length[2];
+ regnode_ssc ch_class; /* pointed to by data */
+ int stclass_flag;
+ SSize_t last_close = 0; /* pointed to by data */
+ regnode *first= scan;
+ regnode *first_next= regnext(first);
+ regnode *last_close_op= NULL;
+ int i;
- /* If the new range ends higher than the current highest ... */
- cur_highest = invlist_highest(invlist);
- if (end > cur_highest) {
+ /*
+ * Skip introductions and multiplicators >= 1
+ * so that we can extract the 'meat' of the pattern that must
+ * match in the large if() sequence following.
+ * NOTE that EXACT is NOT covered here, as it is normally
+ * picked up by the optimiser separately.
+ *
+ * This is unfortunate as the optimiser isnt handling lookahead
+ * properly currently.
+ *
+ */
+ while (1)
+ {
+ if (OP(first) == OPEN)
+ sawopen = 1;
+ else
+ if (OP(first) == IFMATCH && !FLAGS(first))
+ /* for now we can't handle lookbehind IFMATCH */
+ sawlookahead = 1;
+ else
+ if (OP(first) == PLUS)
+ sawplus = 1;
+ else
+ if (OP(first) == MINMOD)
+ sawminmod = 1;
+ else
+ if (!(
+ /* An OR of *one* alternative - should not happen now. */
+ (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
+ /* An {n,m} with n>0 */
+ (REGNODE_TYPE(OP(first)) == CURLY && ARG1i(first) > 0) ||
+ (OP(first) == NOTHING && REGNODE_TYPE(OP(first_next)) != END)
+ )){
+ break;
+ }
- /* If the whole range is higher, we can just append it */
- if (start > cur_highest) {
- _append_range_to_invlist(invlist, start, end);
- return invlist;
+ first = REGNODE_AFTER(first);
+ first_next= regnext(first);
}
- /* Otherwise, add the portion that is higher ... */
- _append_range_to_invlist(invlist, cur_highest + 1, end);
-
- /* ... and continue on below to handle the rest. As a result of the
- * above append, we know that the index of the end of the range is the
- * final even numbered one of the array. Recall that the final element
- * always starts a range that extends to infinity. If that range is in
- * the set (meaning the set goes from here to infinity), it will be an
- * even index, but if it isn't in the set, it's odd, and the final
- * range in the set is one less, which is even. */
- if (end == UV_MAX) {
- i_e = len;
+ /* Starting-point info. */
+ again:
+ DEBUG_PEEP("first:", first, 0, 0);
+ /* Ignore EXACT as we deal with it later. */
+ if (REGNODE_TYPE(OP(first)) == EXACT) {
+ if (! isEXACTFish(OP(first))) {
+ NOOP; /* Empty, get anchored substr later. */
+ }
+ else
+ RExC_rxi->regstclass = first;
}
- else {
- i_e = len - 2;
+#ifdef TRIE_STCLASS
+ else if (REGNODE_TYPE(OP(first)) == TRIE &&
+ ((reg_trie_data *)RExC_rxi->data->data[ ARG1u(first) ])->minlen>0)
+ {
+ /* this can happen only on restudy
+ * Search for "restudy" in this file to find
+ * a comment with details. */
+ RExC_rxi->regstclass = construct_ahocorasick_from_trie(pRExC_state, (regnode *)first, 0);
}
- }
+#endif
+ else if (REGNODE_SIMPLE(OP(first)))
+ RExC_rxi->regstclass = first;
+ else if (REGNODE_TYPE(OP(first)) == BOUND ||
+ REGNODE_TYPE(OP(first)) == NBOUND)
+ RExC_rxi->regstclass = first;
+ else if (REGNODE_TYPE(OP(first)) == BOL) {
+ RExC_rx->intflags |= (OP(first) == MBOL
+ ? PREGf_ANCH_MBOL
+ : PREGf_ANCH_SBOL);
+ first = REGNODE_AFTER(first);
+ goto again;
+ }
+ else if (OP(first) == GPOS) {
+ RExC_rx->intflags |= PREGf_ANCH_GPOS;
+ first = REGNODE_AFTER_type(first,tregnode_GPOS);
+ goto again;
+ }
+ else if ((!sawopen || !RExC_sawback) &&
+ !sawlookahead &&
+ (OP(first) == STAR &&
+ REGNODE_TYPE(OP(REGNODE_AFTER(first))) == REG_ANY) &&
+ !(RExC_rx->intflags & PREGf_ANCH) && !(RExC_seen & REG_PESSIMIZE_SEEN))
+ {
+ /* turn .* into ^.* with an implied $*=1 */
+ const int type =
+ (OP(REGNODE_AFTER(first)) == REG_ANY)
+ ? PREGf_ANCH_MBOL
+ : PREGf_ANCH_SBOL;
+ RExC_rx->intflags |= (type | PREGf_IMPLICIT);
+ first = REGNODE_AFTER(first);
+ goto again;
+ }
+ if (sawplus && !sawminmod && !sawlookahead
+ && (!sawopen || !RExC_sawback)
+ && !(RExC_seen & REG_PESSIMIZE_SEEN)) /* May examine pos and $& */
+ /* x+ must match at the 1st pos of run of x's */
+ RExC_rx->intflags |= PREGf_SKIP;
+
+ /* Scan is after the zeroth branch, first is atomic matcher. */
+#ifdef TRIE_STUDY_OPT
+ /* search for "restudy" in this file for a detailed explanation */
+ DEBUG_PARSE_r(
+ if (!restudied)
+ Perl_re_printf( aTHX_ "first at %" IVdf "\n",
+ (IV)(first - scan + 1))
+ );
+#else
+ DEBUG_PARSE_r(
+ Perl_re_printf( aTHX_ "first at %" IVdf "\n",
+ (IV)(first - scan + 1))
+ );
+#endif
+
- /* We have dealt with appending, now see about prepending. If the new
- * range starts lower than the current lowest ... */
- if (start < array[0]) {
+ /*
+ * If there's something expensive in the r.e., find the
+ * longest literal string that must appear and make it the
+ * regmust. Resolve ties in favor of later strings, since
+ * the regstart check works with the beginning of the r.e.
+ * and avoiding duplication strengthens checking. Not a
+ * strong reason, but sufficient in the absence of others.
+ * [Now we resolve ties in favor of the earlier string if
+ * it happens that c_offset_min has been invalidated, since the
+ * earlier string may buy us something the later one won't.]
+ */
- /* Adding something which has 0 in it is somewhat tricky, and uncommon.
- * Let the union code handle it, rather than having to know the
- * trickiness in two code places. */
- if (UNLIKELY(start == 0)) {
- SV* range_invlist;
+ data.substrs[0].str = newSVpvs("");
+ data.substrs[1].str = newSVpvs("");
+ data.last_found = newSVpvs("");
+ data.cur_is_floating = 0; /* initially any found substring is fixed */
+ ENTER_with_name("study_chunk");
+ SAVEFREESV(data.substrs[0].str);
+ SAVEFREESV(data.substrs[1].str);
+ SAVEFREESV(data.last_found);
+ first = scan;
+ if (!RExC_rxi->regstclass) {
+ ssc_init(pRExC_state, &ch_class);
+ data.start_class = &ch_class;
+ stclass_flag = SCF_DO_STCLASS_AND;
+ } else /* XXXX Check for BOUND? */
+ stclass_flag = 0;
+ data.last_closep = &last_close;
+ data.last_close_opp = &last_close_op;
- range_invlist = _new_invlist(2);
- _append_range_to_invlist(range_invlist, start, end);
+ DEBUG_RExC_seen();
+ /*
+ * MAIN ENTRY FOR study_chunk() FOR m/PATTERN/
+ * (NO top level branches)
+ */
+ minlen = study_chunk(pRExC_state, &first, &minlen, &fake_deltap,
+ scan + RExC_size, /* Up to end */
+ &data, -1, 0, NULL,
+ SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
+ | (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
+ 0, TRUE);
+ /* search for "restudy" in this file for a detailed explanation
+ * of 'restudied' and SCF_TRIE_DOING_RESTUDY */
- _invlist_union(invlist, range_invlist, &invlist);
- SvREFCNT_dec_NN(range_invlist);
+ CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
- return invlist;
- }
- /* If the whole new range comes before the first entry, and doesn't
- * extend it, we have to insert it as an additional range */
- if (end < array[0] - 1) {
- i_s = i_e = -1;
- goto splice_in_new_range;
+ if ( RExC_total_parens == 1 && !data.cur_is_floating
+ && data.last_start_min == 0 && data.last_end > 0
+ && !RExC_seen_zerolen
+ && !(RExC_seen & REG_VERBARG_SEEN)
+ && !(RExC_seen & REG_GPOS_SEEN)
+ ){
+ RExC_rx->extflags |= RXf_CHECK_ALL;
}
+ scan_commit(pRExC_state, &data,&minlen, 0);
- /* Here the new range adjoins the existing first range, extending it
- * downwards. */
- array[0] = start;
-
- /* And continue on below to handle the rest. We know that the index of
- * the beginning of the range is the first one of the array */
- i_s = 0;
- }
- else { /* Not prepending any part of the new range to the existing list.
- * Find where in the list it should go. This finds i_s, such that:
- * invlist[i_s] <= start < array[i_s+1]
- */
- i_s = _invlist_search(invlist, start);
- }
-
- /* At this point, any extending before the beginning of the inversion list
- * and/or after the end has been done. This has made it so that, in the
- * code below, each endpoint of the new range is either in a range that is
- * in the set, or is in a gap between two ranges that are. This means we
- * don't have to worry about exceeding the array bounds.
- *
- * Find where in the list the new range ends (but we can skip this if we
- * have already determined what it is, or if it will be the same as i_s,
- * which we already have computed) */
- if (i_e == 0) {
- i_e = (start == end)
- ? i_s
- : _invlist_search(invlist, end);
- }
- /* Here generally invlist[i_e] <= end < array[i_e+1]. But if invlist[i_e]
- * is a range that goes to infinity there is no element at invlist[i_e+1],
- * so only the first relation holds. */
+ /* XXX this is done in reverse order because that's the way the
+ * code was before it was parameterised. Don't know whether it
+ * actually needs doing in reverse order. DAPM */
+ for (i = 1; i >= 0; i--) {
+ longest_length[i] = CHR_SVLEN(data.substrs[i].str);
- if ( ! ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
+ if ( !( i
+ && SvCUR(data.substrs[0].str) /* ok to leave SvCUR */
+ && data.substrs[0].min_offset
+ == data.substrs[1].min_offset
+ && SvCUR(data.substrs[0].str)
+ == SvCUR(data.substrs[1].str)
+ )
+ && S_setup_longest (aTHX_ pRExC_state,
+ &(RExC_rx->substrs->data[i]),
+ &(data.substrs[i]),
+ longest_length[i]))
+ {
+ RExC_rx->substrs->data[i].min_offset =
+ data.substrs[i].min_offset - data.substrs[i].lookbehind;
- /* Here, the ranges on either side of the beginning of the new range
- * are in the set, and this range starts in the gap between them.
- *
- * The new range extends the range above it downwards if the new range
- * ends at or above that range's start */
- const bool extends_the_range_above = ( end == UV_MAX
- || end + 1 >= array[i_s+1]);
-
- /* The new range extends the range below it upwards if it begins just
- * after where that range ends */
- if (start == array[i_s]) {
-
- /* If the new range fills the entire gap between the other ranges,
- * they will get merged together. Other ranges may also get
- * merged, depending on how many of them the new range spans. In
- * the general case, we do the merge later, just once, after we
- * figure out how many to merge. But in the case where the new
- * range exactly spans just this one gap (possibly extending into
- * the one above), we do the merge here, and an early exit. This
- * is done here to avoid having to special case later. */
- if (i_e - i_s <= 1) {
-
- /* If i_e - i_s == 1, it means that the new range terminates
- * within the range above, and hence 'extends_the_range_above'
- * must be true. (If the range above it extends to infinity,
- * 'i_s+2' will be above the array's limit, but 'len-i_s-2'
- * will be 0, so no harm done.) */
- if (extends_the_range_above) {
- Move(array + i_s + 2, array + i_s, len - i_s - 2, UV);
- invlist_set_len(invlist,
- len - 2,
- *(get_invlist_offset_addr(invlist)));
- return invlist;
- }
-
- /* Here, i_e must == i_s. We keep them in sync, as they apply
- * to the same range, and below we are about to decrement i_s
- * */
- i_e--;
+ RExC_rx->substrs->data[i].max_offset = data.substrs[i].max_offset;
+ /* Don't offset infinity */
+ if (data.substrs[i].max_offset < OPTIMIZE_INFTY)
+ RExC_rx->substrs->data[i].max_offset -= data.substrs[i].lookbehind;
+ SvREFCNT_inc_simple_void_NN(data.substrs[i].str);
}
-
- /* Here, the new range is adjacent to the one below. (It may also
- * span beyond the range above, but that will get resolved later.)
- * Extend the range below to include this one. */
- array[i_s] = (end == UV_MAX) ? UV_MAX : end + 1;
- i_s--;
- start = array[i_s];
- }
- else if (extends_the_range_above) {
-
- /* Here the new range only extends the range above it, but not the
- * one below. It merges with the one above. Again, we keep i_e
- * and i_s in sync if they point to the same range */
- if (i_e == i_s) {
- i_e++;
+ else {
+ RExC_rx->substrs->data[i].substr = NULL;
+ RExC_rx->substrs->data[i].utf8_substr = NULL;
+ longest_length[i] = 0;
}
- i_s++;
- array[i_s] = start;
}
- }
- /* Here, we've dealt with the new range start extending any adjoining
- * existing ranges.
- *
- * If the new range extends to infinity, it is now the final one,
- * regardless of what was there before */
- if (UNLIKELY(end == UV_MAX)) {
- invlist_set_len(invlist, i_s + 1, *(get_invlist_offset_addr(invlist)));
- return invlist;
- }
+ LEAVE_with_name("study_chunk");
- /* If i_e started as == i_s, it has also been dealt with,
- * and been updated to the new i_s, which will fail the following if */
- if (! ELEMENT_RANGE_MATCHES_INVLIST(i_e)) {
+ if (RExC_rxi->regstclass
+ && (OP(RExC_rxi->regstclass) == REG_ANY || OP(RExC_rxi->regstclass) == SANY))
+ RExC_rxi->regstclass = NULL;
- /* Here, the ranges on either side of the end of the new range are in
- * the set, and this range ends in the gap between them.
- *
- * If this range is adjacent to (hence extends) the range above it, it
- * becomes part of that range; likewise if it extends the range below,
- * it becomes part of that range */
- if (end + 1 == array[i_e+1]) {
- i_e++;
- array[i_e] = start;
- }
- else if (start <= array[i_e]) {
- array[i_e] = end + 1;
- i_e--;
- }
- }
+ if ((!(RExC_rx->substrs->data[0].substr || RExC_rx->substrs->data[0].utf8_substr)
+ || RExC_rx->substrs->data[0].min_offset)
+ && stclass_flag
+ && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
+ && is_ssc_worth_it(pRExC_state, data.start_class))
+ {
+ const U32 n = reg_add_data(pRExC_state, STR_WITH_LEN("f"));
- if (i_s == i_e) {
+ ssc_finalize(pRExC_state, data.start_class);
- /* If the range fits entirely in an existing range (as possibly already
- * extended above), it doesn't add anything new */
- if (ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
- return invlist;
+ Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
+ StructCopy(data.start_class,
+ (regnode_ssc*)RExC_rxi->data->data[n],
+ regnode_ssc);
+ RExC_rxi->regstclass = (regnode*)RExC_rxi->data->data[n];
+ RExC_rx->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
+ DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
+ regprop(RExC_rx, sv, (regnode*)data.start_class, NULL, pRExC_state);
+ Perl_re_printf( aTHX_
+ "synthetic stclass \"%s\".\n",
+ SvPVX_const(sv));});
+ data.start_class = NULL;
}
- /* Here, no part of the range is in the list. Must add it. It will
- * occupy 2 more slots */
- splice_in_new_range:
+ /* A temporary algorithm prefers floated substr to fixed one of
+ * same length to dig more info. */
+ i = (longest_length[0] <= longest_length[1]);
+ RExC_rx->substrs->check_ix = i;
+ RExC_rx->check_end_shift = RExC_rx->substrs->data[i].end_shift;
+ RExC_rx->check_substr = RExC_rx->substrs->data[i].substr;
+ RExC_rx->check_utf8 = RExC_rx->substrs->data[i].utf8_substr;
+ RExC_rx->check_offset_min = RExC_rx->substrs->data[i].min_offset;
+ RExC_rx->check_offset_max = RExC_rx->substrs->data[i].max_offset;
+ if (!i && (RExC_rx->intflags & (PREGf_ANCH_SBOL|PREGf_ANCH_GPOS)))
+ RExC_rx->intflags |= PREGf_NOSCAN;
- invlist_extend(invlist, len + 2);
- array = invlist_array(invlist);
- /* Move the rest of the array down two slots. Don't include any
- * trailing NUL */
- Move(array + i_e + 1, array + i_e + 3, len - i_e - 1, UV);
+ if ((RExC_rx->check_substr || RExC_rx->check_utf8) ) {
+ RExC_rx->extflags |= RXf_USE_INTUIT;
+ if (SvTAIL(RExC_rx->check_substr ? RExC_rx->check_substr : RExC_rx->check_utf8))
+ RExC_rx->extflags |= RXf_INTUIT_TAIL;
+ }
- /* Do the actual splice */
- array[i_e+1] = start;
- array[i_e+2] = end + 1;
- invlist_set_len(invlist, len + 2, *(get_invlist_offset_addr(invlist)));
- return invlist;
+ /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
+ if ( (STRLEN)minlen < longest_length[1] )
+ minlen= longest_length[1];
+ if ( (STRLEN)minlen < longest_length[0] )
+ minlen= longest_length[0];
+ */
}
+ else {
+ /* Several toplevels. Best we can is to set minlen. */
+ SSize_t fake_deltap;
+ regnode_ssc ch_class;
+ SSize_t last_close = 0;
+ regnode *last_close_op = NULL;
- /* Here the new range crossed the boundaries of a pre-existing range. The
- * code above has adjusted things so that both ends are in ranges that are
- * in the set. This means everything in between must also be in the set.
- * Just squash things together */
- Move(array + i_e + 1, array + i_s + 1, len - i_e - 1, UV);
- invlist_set_len(invlist,
- len - i_e + i_s,
- *(get_invlist_offset_addr(invlist)));
-
- return invlist;
-}
-
-SV*
-Perl__setup_canned_invlist(pTHX_ const STRLEN size, const UV element0,
- UV** other_elements_ptr)
-{
- /* Create and return an inversion list whose contents are to be populated
- * by the caller. The caller gives the number of elements (in 'size') and
- * the very first element ('element0'). This function will set
- * '*other_elements_ptr' to an array of UVs, where the remaining elements
- * are to be placed.
- *
- * Obviously there is some trust involved that the caller will properly
- * fill in the other elements of the array.
- *
- * (The first element needs to be passed in, as the underlying code does
- * things differently depending on whether it is zero or non-zero) */
-
- SV* invlist = _new_invlist(size);
- bool offset;
-
- PERL_ARGS_ASSERT__SETUP_CANNED_INVLIST;
+ DEBUG_PARSE_r(Perl_re_printf( aTHX_ "\nMulti Top Level\n"));
- invlist = add_cp_to_invlist(invlist, element0);
- offset = *get_invlist_offset_addr(invlist);
+ scan = RExC_rxi->program + 1;
+ ssc_init(pRExC_state, &ch_class);
+ data.start_class = &ch_class;
+ data.last_closep = &last_close;
+ data.last_close_opp = &last_close_op;
- invlist_set_len(invlist, size, offset);
- *other_elements_ptr = invlist_array(invlist) + 1;
- return invlist;
-}
+ DEBUG_RExC_seen();
+ /*
+ * MAIN ENTRY FOR study_chunk() FOR m/P1|P2|.../
+ * (patterns WITH top level branches)
+ */
+ minlen = study_chunk(pRExC_state,
+ &scan, &minlen, &fake_deltap, scan + RExC_size, &data, -1, 0, NULL,
+ SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied
+ ? SCF_TRIE_DOING_RESTUDY
+ : 0),
+ 0, TRUE);
+ /* search for "restudy" in this file for a detailed explanation
+ * of 'restudied' and SCF_TRIE_DOING_RESTUDY */
-#endif
+ CHECK_RESTUDY_GOTO_butfirst(NOOP);
-#ifndef PERL_IN_XSUB_RE
-void
-Perl__invlist_invert(pTHX_ SV* const invlist)
-{
- /* Complement the input inversion list. This adds a 0 if the list didn't
- * have a zero; removes it otherwise. As described above, the data
- * structure is set up so that this is very efficient */
+ RExC_rx->check_substr = NULL;
+ RExC_rx->check_utf8 = NULL;
+ RExC_rx->substrs->data[0].substr = NULL;
+ RExC_rx->substrs->data[0].utf8_substr = NULL;
+ RExC_rx->substrs->data[1].substr = NULL;
+ RExC_rx->substrs->data[1].utf8_substr = NULL;
- PERL_ARGS_ASSERT__INVLIST_INVERT;
+ if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
+ && is_ssc_worth_it(pRExC_state, data.start_class))
+ {
+ const U32 n = reg_add_data(pRExC_state, STR_WITH_LEN("f"));
- assert(! invlist_is_iterating(invlist));
+ ssc_finalize(pRExC_state, data.start_class);
- /* The inverse of matching nothing is matching everything */
- if (_invlist_len(invlist) == 0) {
- _append_range_to_invlist(invlist, 0, UV_MAX);
- return;
+ Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
+ StructCopy(data.start_class,
+ (regnode_ssc*)RExC_rxi->data->data[n],
+ regnode_ssc);
+ RExC_rxi->regstclass = (regnode*)RExC_rxi->data->data[n];
+ RExC_rx->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
+ DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
+ regprop(RExC_rx, sv, (regnode*)data.start_class, NULL, pRExC_state);
+ Perl_re_printf( aTHX_
+ "synthetic stclass \"%s\".\n",
+ SvPVX_const(sv));});
+ data.start_class = NULL;
+ }
}
- *get_invlist_offset_addr(invlist) = ! *get_invlist_offset_addr(invlist);
-}
-
-SV*
-Perl_invlist_clone(pTHX_ SV* const invlist, SV* new_invlist)
-{
- /* Return a new inversion list that is a copy of the input one, which is
- * unchanged. The new list will not be mortal even if the old one was. */
-
- const STRLEN nominal_length = _invlist_len(invlist);
- const STRLEN physical_length = SvCUR(invlist);
- const bool offset = *(get_invlist_offset_addr(invlist));
-
- PERL_ARGS_ASSERT_INVLIST_CLONE;
-
- if (new_invlist == NULL) {
- new_invlist = _new_invlist(nominal_length);
+ if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) {
+ RExC_rx->extflags |= RXf_UNBOUNDED_QUANTIFIER_SEEN;
+ RExC_rx->maxlen = REG_INFTY;
}
else {
- sv_upgrade(new_invlist, SVt_INVLIST);
- initialize_invlist_guts(new_invlist, nominal_length);
+ RExC_rx->maxlen = RExC_maxlen;
}
- *(get_invlist_offset_addr(new_invlist)) = offset;
- invlist_set_len(new_invlist, nominal_length, offset);
- Copy(SvPVX(invlist), SvPVX(new_invlist), physical_length, char);
-
- return new_invlist;
-}
-
-#endif
+ /* Guard against an embedded (?=) or (?<=) with a longer minlen than
+ the "real" pattern. */
+ DEBUG_OPTIMISE_r({
+ Perl_re_printf( aTHX_ "minlen: %" IVdf " RExC_rx->minlen:%" IVdf " maxlen:%" IVdf "\n",
+ (IV)minlen, (IV)RExC_rx->minlen, (IV)RExC_maxlen);
+ });
+ RExC_rx->minlenret = minlen;
+ if (RExC_rx->minlen < minlen)
+ RExC_rx->minlen = minlen;
-PERL_STATIC_INLINE UV
-S_invlist_lowest(SV* const invlist)
-{
- /* Returns the lowest code point that matches an inversion list. This API
- * has an ambiguity, as it returns 0 under either the lowest is actually
- * 0, or if the list is empty. If this distinction matters to you, check
- * for emptiness before calling this function */
+ if (RExC_seen & REG_RECURSE_SEEN ) {
+ RExC_rx->intflags |= PREGf_RECURSE_SEEN;
+ Newx(RExC_rx->recurse_locinput, RExC_rx->nparens + 1, char *);
+ }
+ if (RExC_seen & REG_GPOS_SEEN)
+ RExC_rx->intflags |= PREGf_GPOS_SEEN;
- UV len = _invlist_len(invlist);
- UV *array;
+ if (RExC_seen & REG_PESSIMIZE_SEEN)
+ RExC_rx->intflags |= PREGf_PESSIMIZE_SEEN;
- PERL_ARGS_ASSERT_INVLIST_LOWEST;
+ if (RExC_seen & REG_LOOKBEHIND_SEEN)
+ RExC_rx->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the
+ lookbehind */
+ if (pRExC_state->code_blocks)
+ RExC_rx->extflags |= RXf_EVAL_SEEN;
- if (len == 0) {
- return 0;
+ if (RExC_seen & REG_VERBARG_SEEN) {
+ RExC_rx->intflags |= PREGf_VERBARG_SEEN;
+ RExC_rx->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
}
- array = invlist_array(invlist);
+ if (RExC_seen & REG_CUTGROUP_SEEN)
+ RExC_rx->intflags |= PREGf_CUTGROUP_SEEN;
- return array[0];
-}
+ if (pm_flags & PMf_USE_RE_EVAL)
+ RExC_rx->intflags |= PREGf_USE_RE_EVAL;
-STATIC SV *
-S_invlist_contents(pTHX_ SV* const invlist, const bool traditional_style)
-{
- /* Get the contents of an inversion list into a string SV so that they can
- * be printed out. If 'traditional_style' is TRUE, it uses the format
- * traditionally done for debug tracing; otherwise it uses a format
- * suitable for just copying to the output, with blanks between ranges and
- * a dash between range components */
-
- UV start, end;
- SV* output;
- const char intra_range_delimiter = (traditional_style ? '\t' : '-');
- const char inter_range_delimiter = (traditional_style ? '\n' : ' ');
-
- if (traditional_style) {
- output = newSVpvs("\n");
- }
- else {
- output = newSVpvs("");
- }
+ if (RExC_paren_names)
+ RXp_PAREN_NAMES(RExC_rx) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
+ else
+ RXp_PAREN_NAMES(RExC_rx) = NULL;
- PERL_ARGS_ASSERT_INVLIST_CONTENTS;
-
- assert(! invlist_is_iterating(invlist));
-
- invlist_iterinit(invlist);
- while (invlist_iternext(invlist, &start, &end)) {
- if (end == UV_MAX) {
- Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%cINFTY%c",
- start, intra_range_delimiter,
- inter_range_delimiter);
- }
- else if (end != start) {
- Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c%04" UVXf "%c",
- start,
- intra_range_delimiter,
- end, inter_range_delimiter);
- }
- else {
- Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c",
- start, inter_range_delimiter);
- }
- }
+ /* If we have seen an anchor in our pattern then we set the extflag RXf_IS_ANCHORED
+ * so it can be used in pp.c */
+ if (RExC_rx->intflags & PREGf_ANCH)
+ RExC_rx->extflags |= RXf_IS_ANCHORED;
- if (SvCUR(output) && ! traditional_style) {/* Get rid of trailing blank */
- SvCUR_set(output, SvCUR(output) - 1);
- }
- return output;
-}
+ {
+ /* this is used to identify "special" patterns that might result
+ * in Perl NOT calling the regex engine and instead doing the match "itself",
+ * particularly special cases in split//. By having the regex compiler
+ * do this pattern matching at a regop level (instead of by inspecting the pattern)
+ * we avoid weird issues with equivalent patterns resulting in different behavior,
+ * AND we allow non Perl engines to get the same optimizations by the setting the
+ * flags appropriately - Yves */
+ regnode *first = RExC_rxi->program + 1;
+ U8 fop = OP(first);
+ regnode *next = NULL;
+ U8 nop = 0;
+ if (fop == NOTHING || fop == MBOL || fop == SBOL || fop == PLUS) {
+ next = REGNODE_AFTER(first);
+ nop = OP(next);
+ }
+ /* It's safe to read through *next only if OP(first) is a regop of
+ * the right type (not EXACT, for example).
+ */
+ if (REGNODE_TYPE(fop) == NOTHING && nop == END)
+ RExC_rx->extflags |= RXf_NULL;
+ else if ((fop == MBOL || (fop == SBOL && !FLAGS(first))) && nop == END)
+ /* when fop is SBOL first->flags will be true only when it was
+ * produced by parsing /\A/, and not when parsing /^/. This is
+ * very important for the split code as there we want to
+ * treat /^/ as /^/m, but we do not want to treat /\A/ as /^/m.
+ * See rt #122761 for more details. -- Yves */
+ RExC_rx->extflags |= RXf_START_ONLY;
+ else if (fop == PLUS
+ && REGNODE_TYPE(nop) == POSIXD && FLAGS(next) == CC_SPACE_
+ && OP(regnext(first)) == END)
+ RExC_rx->extflags |= RXf_WHITE;
+ else if ( RExC_rx->extflags & RXf_SPLIT
+ && (REGNODE_TYPE(fop) == EXACT && ! isEXACTFish(fop))
+ && STR_LEN(first) == 1
+ && *(STRING(first)) == ' '
+ && OP(regnext(first)) == END )
+ RExC_rx->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
-#ifndef PERL_IN_XSUB_RE
-void
-Perl__invlist_dump(pTHX_ PerlIO *file, I32 level,
- const char * const indent, SV* const invlist)
-{
- /* Designed to be called only by do_sv_dump(). Dumps out the ranges of the
- * inversion list 'invlist' to 'file' at 'level' Each line is prefixed by
- * the string 'indent'. The output looks like this:
- [0] 0x000A .. 0x000D
- [2] 0x0085
- [4] 0x2028 .. 0x2029
- [6] 0x3104 .. INFTY
- * This means that the first range of code points matched by the list are
- * 0xA through 0xD; the second range contains only the single code point
- * 0x85, etc. An inversion list is an array of UVs. Two array elements
- * are used to define each range (except if the final range extends to
- * infinity, only a single element is needed). The array index of the
- * first element for the corresponding range is given in brackets. */
-
- UV start, end;
- STRLEN count = 0;
-
- PERL_ARGS_ASSERT__INVLIST_DUMP;
-
- if (invlist_is_iterating(invlist)) {
- Perl_dump_indent(aTHX_ level, file,
- "%sCan't dump inversion list because is in middle of iterating\n",
- indent);
- return;
}
- invlist_iterinit(invlist);
- while (invlist_iternext(invlist, &start, &end)) {
- if (end == UV_MAX) {
- Perl_dump_indent(aTHX_ level, file,
- "%s[%" UVuf "] 0x%04" UVXf " .. INFTY\n",
- indent, (UV)count, start);
- }
- else if (end != start) {
- Perl_dump_indent(aTHX_ level, file,
- "%s[%" UVuf "] 0x%04" UVXf " .. 0x%04" UVXf "\n",
- indent, (UV)count, start, end);
- }
- else {
- Perl_dump_indent(aTHX_ level, file, "%s[%" UVuf "] 0x%04" UVXf "\n",
- indent, (UV)count, start);
- }
- count += 2;
+ if (RExC_contains_locale) {
+ RXp_EXTFLAGS(RExC_rx) |= RXf_TAINTED;
}
-}
+#ifdef DEBUGGING
+ if (RExC_paren_names) {
+ RExC_rxi->name_list_idx = reg_add_data( pRExC_state, STR_WITH_LEN("a"));
+ RExC_rxi->data->data[RExC_rxi->name_list_idx]
+ = (void*)SvREFCNT_inc(RExC_paren_name_list);
+ } else
#endif
+ RExC_rxi->name_list_idx = 0;
-#if defined(PERL_ARGS_ASSERT__INVLISTEQ) && !defined(PERL_IN_XSUB_RE)
-bool
-Perl__invlistEQ(pTHX_ SV* const a, SV* const b, const bool complement_b)
-{
- /* Return a boolean as to if the two passed in inversion lists are
- * identical. The final argument, if TRUE, says to take the complement of
- * the second inversion list before doing the comparison */
+ while ( RExC_recurse_count > 0 ) {
+ const regnode *scan = RExC_recurse[ --RExC_recurse_count ];
+ /*
+ * This data structure is set up in study_chunk() and is used
+ * to calculate the distance between a GOSUB regopcode and
+ * the OPEN/CURLYM (CURLYM's are special and can act like OPEN's)
+ * it refers to.
+ *
+ * If for some reason someone writes code that optimises
+ * away a GOSUB opcode then the assert should be changed to
+ * an if(scan) to guard the ARG2i_SET() - Yves
+ *
+ */
+ assert(scan && OP(scan) == GOSUB);
+ ARG2i_SET( scan, RExC_open_parens[ARG1u(scan)] - REGNODE_OFFSET(scan));
+ }
+ if (RExC_logical_total_parens != RExC_total_parens) {
+ Newxz(RExC_parno_to_logical_next, RExC_total_parens, I32);
+ /* we rebuild this below */
+ Zero(RExC_logical_to_parno, RExC_total_parens, I32);
+ for( int parno = RExC_total_parens-1 ; parno > 0 ; parno-- ) {
+ int logical_parno= RExC_parno_to_logical[parno];
+ assert(logical_parno);
+ RExC_parno_to_logical_next[parno]= RExC_logical_to_parno[logical_parno];
+ RExC_logical_to_parno[logical_parno] = parno;
+ }
+ RExC_rx->logical_to_parno = RExC_logical_to_parno;
+ RExC_rx->parno_to_logical = RExC_parno_to_logical;
+ RExC_rx->parno_to_logical_next = RExC_parno_to_logical_next;
+ RExC_logical_to_parno = NULL;
+ RExC_parno_to_logical = NULL;
+ RExC_parno_to_logical_next = NULL;
+ } else {
+ RExC_rx->logical_to_parno = NULL;
+ RExC_rx->parno_to_logical = NULL;
+ RExC_rx->parno_to_logical_next = NULL;
+ }
- const UV len_a = _invlist_len(a);
- UV len_b = _invlist_len(b);
+ Newxz(RXp_OFFSp(RExC_rx), RExC_total_parens, regexp_paren_pair);
+ /* assume we don't need to swap parens around before we match */
+ DEBUG_TEST_r({
+ Perl_re_printf( aTHX_ "study_chunk_recursed_count: %lu\n",
+ (unsigned long)RExC_study_chunk_recursed_count);
+ });
+ DEBUG_DUMP_r({
+ DEBUG_RExC_seen();
+ Perl_re_printf( aTHX_ "Final program:\n");
+ regdump(RExC_rx);
+ });
- const UV* array_a = NULL;
- const UV* array_b = NULL;
+ if (RExC_open_parens) {
+ Safefree(RExC_open_parens);
+ RExC_open_parens = NULL;
+ }
+ if (RExC_close_parens) {
+ Safefree(RExC_close_parens);
+ RExC_close_parens = NULL;
+ }
+ if (RExC_logical_to_parno) {
+ Safefree(RExC_logical_to_parno);
+ RExC_logical_to_parno = NULL;
+ }
+ if (RExC_parno_to_logical) {
+ Safefree(RExC_parno_to_logical);
+ RExC_parno_to_logical = NULL;
+ }
- PERL_ARGS_ASSERT__INVLISTEQ;
+#ifdef USE_ITHREADS
+ /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
+ * by setting the regexp SV to readonly-only instead. If the
+ * pattern's been recompiled, the USEDness should remain. */
+ if (old_re && SvREADONLY(old_re))
+ SvREADONLY_on(Rx);
+#endif
+ return Rx;
+}
- /* This code avoids accessing the arrays unless it knows the length is
- * non-zero */
- if (len_a == 0) {
- if (len_b == 0) {
- return ! complement_b;
- }
- }
- else {
- array_a = invlist_array(a);
- }
- if (len_b != 0) {
- array_b = invlist_array(b);
- }
+SV*
+Perl_reg_qr_package(pTHX_ REGEXP * const rx)
+{
+ PERL_ARGS_ASSERT_REG_QR_PACKAGE;
+ PERL_UNUSED_ARG(rx);
+ if (0)
+ return NULL;
+ else
+ return newSVpvs("Regexp");
+}
- /* If are to compare 'a' with the complement of b, set it
- * up so are looking at b's complement. */
- if (complement_b) {
+/* Scans the name of a named buffer from the pattern.
+ * If flags is REG_RSN_RETURN_NULL returns null.
+ * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
+ * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
+ * to the parsed name as looked up in the RExC_paren_names hash.
+ * If there is an error throws a vFAIL().. type exception.
+ */
- /* The complement of nothing is everything, so <a> would have to have
- * just one element, starting at zero (ending at infinity) */
- if (len_b == 0) {
- return (len_a == 1 && array_a[0] == 0);
- }
- if (array_b[0] == 0) {
+#define REG_RSN_RETURN_NULL 0
+#define REG_RSN_RETURN_NAME 1
+#define REG_RSN_RETURN_DATA 2
- /* Otherwise, to complement, we invert. Here, the first element is
- * 0, just remove it. To do this, we just pretend the array starts
- * one later */
+STATIC SV*
+S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
+{
+ char *name_start = RExC_parse;
+ SV* sv_name;
- array_b++;
- len_b--;
- }
- else {
+ PERL_ARGS_ASSERT_REG_SCAN_NAME;
- /* But if the first element is not zero, we pretend the list starts
- * at the 0 that is always stored immediately before the array. */
- array_b--;
- len_b++;
- }
+ assert (RExC_parse <= RExC_end);
+ if (RExC_parse == RExC_end) NOOP;
+ else if (isIDFIRST_lazy_if_safe(RExC_parse, RExC_end, UTF)) {
+ /* Note that the code here assumes well-formed UTF-8. Skip IDFIRST by
+ * using do...while */
+ if (UTF)
+ do {
+ RExC_parse_inc_utf8();
+ } while ( RExC_parse < RExC_end
+ && isWORDCHAR_utf8_safe((U8*)RExC_parse, (U8*) RExC_end));
+ else
+ do {
+ RExC_parse_inc_by(1);
+ } while (RExC_parse < RExC_end && isWORDCHAR(*RExC_parse));
+ } else {
+ RExC_parse_inc_by(1); /* so the <- from the vFAIL is after the offending
+ character */
+ vFAIL("Group name must start with a non-digit word character");
}
+ sv_name = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
+ SVs_TEMP | (UTF ? SVf_UTF8 : 0));
+ if ( flags == REG_RSN_RETURN_NAME)
+ return sv_name;
+ else if (flags==REG_RSN_RETURN_DATA) {
+ HE *he_str = NULL;
+ SV *sv_dat = NULL;
+ if ( ! sv_name ) /* should not happen*/
+ Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
+ if (RExC_paren_names)
+ he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
+ if ( he_str )
+ sv_dat = HeVAL(he_str);
+ if ( ! sv_dat ) { /* Didn't find group */
- return len_a == len_b
- && memEQ(array_a, array_b, len_a * sizeof(array_a[0]));
-
-}
-#endif
-
-/*
- * As best we can, determine the characters that can match the start of
- * the given EXACTF-ish node. This is for use in creating ssc nodes, so there
- * can be false positive matches
- *
- * Returns the invlist as a new SV*; it is the caller's responsibility to
- * call SvREFCNT_dec() when done with it.
- */
-STATIC SV*
-S_make_exactf_invlist(pTHX_ RExC_state_t *pRExC_state, regnode *node)
-{
- const U8 * s = (U8*)STRING(node);
- SSize_t bytelen = STR_LEN(node);
- UV uc;
- /* Start out big enough for 2 separate code points */
- SV* invlist = _new_invlist(4);
-
- PERL_ARGS_ASSERT_MAKE_EXACTF_INVLIST;
-
- if (! UTF) {
- uc = *s;
-
- /* We punt and assume can match anything if the node begins
- * with a multi-character fold. Things are complicated. For
- * example, /ffi/i could match any of:
- * "\N{LATIN SMALL LIGATURE FFI}"
- * "\N{LATIN SMALL LIGATURE FF}I"
- * "F\N{LATIN SMALL LIGATURE FI}"
- * plus several other things; and making sure we have all the
- * possibilities is hard. */
- if (is_MULTI_CHAR_FOLD_latin1_safe(s, s + bytelen)) {
- invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
- }
- else {
- /* Any Latin1 range character can potentially match any
- * other depending on the locale, and in Turkic locales, U+130 and
- * U+131 */
- if (OP(node) == EXACTFL) {
- _invlist_union(invlist, PL_Latin1, &invlist);
- invlist = add_cp_to_invlist(invlist,
- LATIN_SMALL_LETTER_DOTLESS_I);
- invlist = add_cp_to_invlist(invlist,
- LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
+ /* It might be a forward reference; we can't fail until we
+ * know, by completing the parse to get all the groups, and
+ * then reparsing */
+ if (ALL_PARENS_COUNTED) {
+ vFAIL("Reference to nonexistent named group");
}
else {
- /* But otherwise, it matches at least itself. We can
- * quickly tell if it has a distinct fold, and if so,
- * it matches that as well */
- invlist = add_cp_to_invlist(invlist, uc);
- if (IS_IN_SOME_FOLD_L1(uc))
- invlist = add_cp_to_invlist(invlist, PL_fold_latin1[uc]);
- }
-
- /* Some characters match above-Latin1 ones under /i. This
- * is true of EXACTFL ones when the locale is UTF-8 */
- if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(uc)
- && (! isASCII(uc) || ! inRANGE(OP(node), EXACTFAA,
- EXACTFAA_NO_TRIE)))
- {
- add_above_Latin1_folds(pRExC_state, (U8) uc, &invlist);
+ REQUIRE_PARENS_PASS;
}
}
+ return sv_dat;
}
- else { /* Pattern is UTF-8 */
- U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1] = { '\0' };
- const U8* e = s + bytelen;
- IV fc;
-
- fc = uc = utf8_to_uvchr_buf(s, s + bytelen, NULL);
-
- /* The only code points that aren't folded in a UTF EXACTFish
- * node are the problematic ones in EXACTFL nodes */
- if (OP(node) == EXACTFL && is_PROBLEMATIC_LOCALE_FOLDEDS_START_cp(uc)) {
- /* We need to check for the possibility that this EXACTFL
- * node begins with a multi-char fold. Therefore we fold
- * the first few characters of it so that we can make that
- * check */
- U8 *d = folded;
- int i;
-
- fc = -1;
- for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < e; i++) {
- if (isASCII(*s)) {
- *(d++) = (U8) toFOLD(*s);
- if (fc < 0) { /* Save the first fold */
- fc = *(d-1);
- }
- s++;
- }
- else {
- STRLEN len;
- UV fold = toFOLD_utf8_safe(s, e, d, &len);
- if (fc < 0) { /* Save the first fold */
- fc = fold;
- }
- d += len;
- s += UTF8SKIP(s);
- }
- }
-
- /* And set up so the code below that looks in this folded
- * buffer instead of the node's string */
- e = d;
- s = folded;
- }
-
- /* When we reach here 's' points to the fold of the first
- * character(s) of the node; and 'e' points to far enough along
- * the folded string to be just past any possible multi-char
- * fold.
- *
- * Like the non-UTF case above, we punt if the node begins with a
- * multi-char fold */
-
- if (is_MULTI_CHAR_FOLD_utf8_safe(s, e)) {
- invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
- }
- else { /* Single char fold */
- unsigned int k;
- U32 first_fold;
- const U32 * remaining_folds;
- Size_t folds_count;
-
- /* It matches itself */
- invlist = add_cp_to_invlist(invlist, fc);
-
- /* ... plus all the things that fold to it, which are found in
- * PL_utf8_foldclosures */
- folds_count = _inverse_folds(fc, &first_fold,
- &remaining_folds);
- for (k = 0; k < folds_count; k++) {
- UV c = (k == 0) ? first_fold : remaining_folds[k-1];
-
- /* /aa doesn't allow folds between ASCII and non- */
- if ( inRANGE(OP(node), EXACTFAA, EXACTFAA_NO_TRIE)
- && isASCII(c) != isASCII(fc))
- {
- continue;
- }
- invlist = add_cp_to_invlist(invlist, c);
- }
+ Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
+ (unsigned long) flags);
+}
- if (OP(node) == EXACTFL) {
+#define DEBUG_PARSE_MSG(funcname) DEBUG_PARSE_r({ \
+ if (RExC_lastparse!=RExC_parse) { \
+ Perl_re_printf( aTHX_ "%s", \
+ Perl_pv_pretty(aTHX_ RExC_mysv1, RExC_parse, \
+ RExC_end - RExC_parse, 16, \
+ "", "", \
+ PERL_PV_ESCAPE_UNI_DETECT | \
+ PERL_PV_PRETTY_ELLIPSES | \
+ PERL_PV_PRETTY_LTGT | \
+ PERL_PV_ESCAPE_RE | \
+ PERL_PV_PRETTY_EXACTSIZE \
+ ) \
+ ); \
+ } else \
+ Perl_re_printf( aTHX_ "%16s",""); \
+ \
+ if (RExC_lastnum!=RExC_emit) \
+ Perl_re_printf( aTHX_ "|%4zu", RExC_emit); \
+ else \
+ Perl_re_printf( aTHX_ "|%4s",""); \
+ Perl_re_printf( aTHX_ "|%*s%-4s", \
+ (int)((depth*2)), "", \
+ (funcname) \
+ ); \
+ RExC_lastnum=RExC_emit; \
+ RExC_lastparse=RExC_parse; \
+})
- /* If either [iI] are present in an EXACTFL node the above code
- * should have added its normal case pair, but under a Turkish
- * locale they could match instead the case pairs from it. Add
- * those as potential matches as well */
- if (isALPHA_FOLD_EQ(fc, 'I')) {
- invlist = add_cp_to_invlist(invlist,
- LATIN_SMALL_LETTER_DOTLESS_I);
- invlist = add_cp_to_invlist(invlist,
- LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
- }
- else if (fc == LATIN_SMALL_LETTER_DOTLESS_I) {
- invlist = add_cp_to_invlist(invlist, 'I');
- }
- else if (fc == LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE) {
- invlist = add_cp_to_invlist(invlist, 'i');
- }
- }
- }
- }
- return invlist;
-}
-#undef HEADER_LENGTH
-#undef TO_INTERNAL_SIZE
-#undef FROM_INTERNAL_SIZE
-#undef INVLIST_VERSION_ID
+#define DEBUG_PARSE(funcname) DEBUG_PARSE_r({ \
+ DEBUG_PARSE_MSG((funcname)); \
+ Perl_re_printf( aTHX_ "%4s","\n"); \
+})
+#define DEBUG_PARSE_FMT(funcname,fmt,args) DEBUG_PARSE_r({\
+ DEBUG_PARSE_MSG((funcname)); \
+ Perl_re_printf( aTHX_ fmt "\n",args); \
+})
-/* End of inversion list object */
STATIC void
S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state)
/* '^' as an initial flag sets certain defaults */
if (UCHARAT(RExC_parse) == '^') {
- RExC_parse++;
+ RExC_parse_inc_by(1);
has_use_defaults = TRUE;
STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
cs = (toUSE_UNI_CHARSET_NOT_DEPENDS)
if ((RExC_pm_flags & PMf_WILDCARD)) {
if (flagsp == & negflags) {
if (*RExC_parse == 'm') {
- RExC_parse++;
+ RExC_parse_inc_by(1);
/* diag_listed_as: Use of %s is not allowed in Unicode
property wildcard subpatterns in regex; marked by <--
HERE in m/%s/ */
has_charset_modifier = DEPENDS_PAT_MOD;
break;
excess_modifier:
- RExC_parse++;
+ RExC_parse_inc_by(1);
if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
}
}
NOT_REACHED; /*NOTREACHED*/
neg_modifier:
- RExC_parse++;
+ RExC_parse_inc_by(1);
vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"",
*(RExC_parse - 1));
NOT_REACHED; /*NOTREACHED*/
: WASTED_G;
if (! (wastedflags & wflagbit) ) {
wastedflags |= wflagbit;
- /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
+ /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
vWARN5(
RExC_parse + 1,
"Useless (%s%c) - %suse /%c modifier",
if (ckWARN(WARN_REGEXP)) {
if (! (wastedflags & WASTED_C) ) {
wastedflags |= WASTED_GC;
- /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
+ /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
vWARN3(
RExC_parse + 1,
"Useless (%sc) - %suse /gc modifier",
if ( (RExC_pm_flags & PMf_WILDCARD)
&& cs != REGEX_ASCII_MORE_RESTRICTED_CHARSET)
{
- RExC_parse++;
+ RExC_parse_inc_by(1);
/* diag_listed_as: Use of %s is not allowed in Unicode
property wildcard subpatterns in regex; marked by <--
HERE in m/%s/ */
return;
default:
fail_modifiers:
- RExC_parse += SKIP_IF_CHAR(RExC_parse, RExC_end);
- /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
+ RExC_parse_inc_if_char();
+ /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
vFAIL2utf8f("Sequence (%" UTF8f "...) not recognized",
UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
NOT_REACHED; /*NOTREACHED*/
}
- RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
+ RExC_parse_inc();
}
vFAIL("Sequence (?... not terminated");
modifier_illegal_in_wildcard:
- RExC_parse++;
+ RExC_parse_inc_by(1);
/* diag_listed_as: Use of %s is not allowed in Unicode property wildcard
subpatterns in regex; marked by <-- HERE in m/%s/ */
vFAIL2("Use of modifier '%c' is not allowed in Unicode property wildcard"
* is a trifle forced, but the need to tie the tails of the branches to what
* follows makes it hard to avoid.
*/
-#define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
-#ifdef DEBUGGING
-#define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
-#else
-#define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
-#endif
STATIC regnode_offset
S_handle_named_backref(pTHX_ RExC_state_t *pRExC_state,
I32 *flagp,
- char * parse_start,
+ char * backref_parse_start,
char ch
)
{
PERL_ARGS_ASSERT_HANDLE_NAMED_BACKREF;
+ if (RExC_parse != name_start && ch == '}') {
+ while (isBLANK(*RExC_parse)) {
+ RExC_parse_inc_by(1);
+ }
+ }
if (RExC_parse == name_start || *RExC_parse != ch) {
/* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
- vFAIL2("Sequence %.3s... not terminated", parse_start);
+ vFAIL2("Sequence %.3s... not terminated", backref_parse_start);
}
if (sv_dat) {
- num = add_data( pRExC_state, STR_WITH_LEN("S"));
+ num = reg_add_data( pRExC_state, STR_WITH_LEN("S"));
RExC_rxi->data->data[num]=(void*)sv_dat;
SvREFCNT_inc_simple_void_NN(sv_dat);
}
RExC_sawback = 1;
- ret = reganode(pRExC_state,
+ ret = reg2node(pRExC_state,
((! FOLD)
? REFN
: (ASCII_FOLD_RESTRICTED)
: (LOC)
? REFFLN
: REFFN),
- num);
+ num, RExC_nestroot);
+ if (RExC_nestroot && num >= (U32)RExC_nestroot)
+ FLAGS(REGNODE_p(ret)) = VOLATILE_REF;
*flagp |= HASWIDTH;
- Set_Node_Offset(REGNODE_p(ret), parse_start+1);
- Set_Node_Cur_Length(REGNODE_p(ret), parse_start);
-
nextchar(pRExC_state);
return ret;
}
+/* reg_la_NOTHING()
+ *
+ * Maybe parse a parenthesized lookaround construct that is equivalent to a
+ * NOTHING regop when the construct is empty.
+ *
+ * Calls skip_to_be_ignored_text() before checking if the construct is empty.
+ *
+ * Checks for unterminated constructs and throws a "not terminated" error
+ * with the appropriate type if necessary
+ *
+ * Assuming it does not throw an exception increments RExC_seen_zerolen.
+ *
+ * If the construct is empty generates a NOTHING op and returns its
+ * regnode_offset, which the caller would then return to its caller.
+ *
+ * If the construct is not empty increments RExC_in_lookaround, and turns
+ * on any flags provided in RExC_seen, and then returns 0 to signify
+ * that parsing should continue.
+ *
+ * PS: I would have called this reg_parse_lookaround_NOTHING() but then
+ * any use of it would have had to be broken onto multiple lines, hence
+ * the abbreviation.
+ */
+STATIC regnode_offset
+S_reg_la_NOTHING(pTHX_ RExC_state_t *pRExC_state, U32 flags,
+ const char *type)
+{
+
+ PERL_ARGS_ASSERT_REG_LA_NOTHING;
+
+ /* false below so we do not force /x */
+ skip_to_be_ignored_text(pRExC_state, &RExC_parse, FALSE);
+
+ if (RExC_parse >= RExC_end)
+ vFAIL2("Sequence (%s... not terminated", type);
+
+ /* Always increment as NOTHING regops are zerolen */
+ RExC_seen_zerolen++;
+
+ if (*RExC_parse == ')') {
+ regnode_offset ret= reg_node(pRExC_state, NOTHING);
+ nextchar(pRExC_state);
+ return ret;
+ }
+
+ RExC_seen |= flags;
+ RExC_in_lookaround++;
+ return 0; /* keep parsing! */
+}
+
+/* reg_la_OPFAIL()
+ *
+ * Maybe parse a parenthesized lookaround construct that is equivalent to a
+ * OPFAIL regop when the construct is empty.
+ *
+ * Calls skip_to_be_ignored_text() before checking if the construct is empty.
+ *
+ * Checks for unterminated constructs and throws a "not terminated" error
+ * if necessary.
+ *
+ * If the construct is empty generates an OPFAIL op and returns its
+ * regnode_offset which the caller should then return to its caller.
+ *
+ * If the construct is not empty increments RExC_in_lookaround, and also
+ * increments RExC_seen_zerolen, and turns on the flags provided in
+ * RExC_seen, and then returns 0 to signify that parsing should continue.
+ *
+ * PS: I would have called this reg_parse_lookaround_OPFAIL() but then
+ * any use of it would have had to be broken onto multiple lines, hence
+ * the abbreviation.
+ */
+
+STATIC regnode_offset
+S_reg_la_OPFAIL(pTHX_ RExC_state_t *pRExC_state, U32 flags,
+ const char *type)
+{
+
+ PERL_ARGS_ASSERT_REG_LA_OPFAIL;
+
+ /* FALSE so we don't force to /x below */;
+ skip_to_be_ignored_text(pRExC_state, &RExC_parse, FALSE);
+
+ if (RExC_parse >= RExC_end)
+ vFAIL2("Sequence (%s... not terminated", type);
+
+ if (*RExC_parse == ')') {
+ regnode_offset ret= reg1node(pRExC_state, OPFAIL, 0);
+ nextchar(pRExC_state);
+ return ret; /* return produced regop */
+ }
+
+ /* only increment zerolen *after* we check if we produce an OPFAIL
+ * as an OPFAIL does not match a zero length construct, as it
+ * does not match ever. */
+ RExC_seen_zerolen++;
+ RExC_seen |= flags;
+ RExC_in_lookaround++;
+ return 0; /* keep parsing! */
+}
+
+/* Below are the main parsing routines.
+ *
+ * S_reg() parses a whole pattern or subpattern. It itself handles things
+ * like the 'xyz' in '(?xyz:...)', and calls S_regbranch for each
+ * alternation '|' in the '...' pattern.
+ * S_regbranch() effectively implements the concatenation operator, handling
+ * one alternative of '|', repeatedly calling S_regpiece on each
+ * segment of the input.
+ * S_regpiece() calls S_regatom to handle the next atomic chunk of the input,
+ * and then adds any quantifier for that chunk.
+ * S_regatom() parses the next chunk of the input, returning when it
+ * determines it has found a complete atomic chunk. The chunk may
+ * be a nested subpattern, in which case S_reg is called
+ * recursively
+ *
+ * The functions generate regnodes as they go along, appending each to the
+ * pattern data structure so far. They return the offset of the current final
+ * node into that structure, or 0 on failure.
+ *
+ * There are three parameters common to all of them:
+ * pRExC_state is a structure with much information about the current
+ * state of the parse. It's easy to add new elements to
+ * convey new information, but beware that an error return may
+ * require clearing the element.
+ * flagp is a pointer to bit flags set in a lower level to pass up
+ * to higher levels information, such as the cause of a
+ * failure, or some characteristic about the generated node
+ * depth is roughly the recursion depth, mostly unused except for
+ * pretty printing debugging info.
+ *
+ * There are ancillary functions that these may farm work out to, using the
+ * same parameters.
+ *
+ * The protocol for handling flags is that each function will, before
+ * returning, add into *flagp the flags it needs to pass up. Each function has
+ * a second flags variable, typically named 'flags', which it sets and clears
+ * at will. Flag bits in it are used in that function, and it calls the next
+ * layer down with its 'flagp' parameter set to '&flags'. Thus, upon return,
+ * 'flags' will contain whatever it had before the call, plus whatever that
+ * function passed up. If it wants to pass any of these up to its caller, it
+ * has to add them to its *flagp. This means that it takes extra steps to keep
+ * passing a flag upwards, and otherwise the flag bit is cleared for higher
+ * functions.
+ */
+
/* On success, returns the offset at which any next node should be placed into
* the regex engine program being compiled.
*
regnode_offset br;
regnode_offset lastbr;
regnode_offset ender = 0;
+ I32 logical_parno = 0;
I32 parno = 0;
I32 flags;
U32 oregflags = RExC_flags;
I32 num; /* numeric backreferences */
SV * max_open; /* Max number of unclosed parens */
I32 was_in_lookaround = RExC_in_lookaround;
+ I32 fake_eval = 0; /* matches paren */
+
+ /* The difference between the following variables can be seen with *
+ * the broken pattern /(?:foo/ where segment_parse_start will point *
+ * at the 'f', and reg_parse_start will point at the '(' */
- char * parse_start = RExC_parse; /* MJD */
- char * const oregcomp_parse = RExC_parse;
+ /* the following is used for unmatched '(' errors */
+ char * const reg_parse_start = RExC_parse;
+
+ /* the following is used to track where various segments of
+ * the pattern that we parse out started. */
+ char * segment_parse_start = RExC_parse;
DECLARE_AND_GET_RE_DEBUG_FLAGS;
/* Having this true makes it feasible to have a lot fewer tests for the
* parse pointer being in scope. For example, we can write
- * while(isFOO(*RExC_parse)) RExC_parse++;
+ * while(isFOO(*RExC_parse)) RExC_parse_inc_by(1);
* instead of
- * while(RExC_parse < RExC_end && isFOO(*RExC_parse)) RExC_parse++;
+ * while(RExC_parse < RExC_end && isFOO(*RExC_parse)) RExC_parse_inc_by(1);
*/
assert(*RExC_end == '\0');
&& *(RExC_parse - 1) != '(';
if (RExC_parse >= RExC_end) {
- vFAIL("Unmatched (");
+ vFAIL("Unmatched (");
}
if (paren == 'r') { /* Atomic script run */
goto parse_rest;
}
else if ( *RExC_parse == '*') { /* (*VERB:ARG), (*construct:...) */
- char *start_verb = RExC_parse + 1;
- STRLEN verb_len;
- char *start_arg = NULL;
- unsigned char op = 0;
+ if (RExC_parse[1] == '{') { /* (*{ ... }) optimistic EVAL */
+ fake_eval = '{';
+ goto handle_qmark;
+ }
+
+ char *start_verb = RExC_parse + 1;
+ STRLEN verb_len;
+ char *start_arg = NULL;
+ unsigned char op = 0;
int arg_required = 0;
- int internal_argval = -1; /* if >-1 we are not allowed an argument*/
+ int internal_argval = -1; /* if > -1 no argument allowed */
bool has_upper = FALSE;
+ U32 seen_flag_set = 0; /* RExC_seen flags we must set */
if (has_intervening_patws) {
- RExC_parse++; /* past the '*' */
+ RExC_parse_inc_by(1); /* past the '*' */
/* For strict backwards compatibility, don't change the message
* now that we also have lowercase operands */
vFAIL("In '(*...)', the '(' and '*' must be adjacent");
}
}
- while (RExC_parse < RExC_end && *RExC_parse != ')' ) {
- if ( *RExC_parse == ':' ) {
- start_arg = RExC_parse + 1;
- break;
- }
+ while (RExC_parse < RExC_end && *RExC_parse != ')' ) {
+ if ( *RExC_parse == ':' ) {
+ start_arg = RExC_parse + 1;
+ break;
+ }
else if (! UTF) {
if (isUPPER(*RExC_parse)) {
has_upper = TRUE;
}
- RExC_parse++;
+ RExC_parse_inc_by(1);
}
else {
- RExC_parse += UTF8SKIP(RExC_parse);
+ RExC_parse_inc_utf8();
}
- }
- verb_len = RExC_parse - start_verb;
- if ( start_arg ) {
+ }
+ verb_len = RExC_parse - start_verb;
+ if ( start_arg ) {
if (RExC_parse >= RExC_end) {
goto unterminated_verb_pattern;
}
- RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
- while ( RExC_parse < RExC_end && *RExC_parse != ')' ) {
- RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
+ RExC_parse_inc();
+ while ( RExC_parse < RExC_end && *RExC_parse != ')' ) {
+ RExC_parse_inc();
}
- if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) {
+ if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) {
unterminated_verb_pattern:
if (has_upper) {
vFAIL("Unterminated verb pattern argument");
vFAIL("Unterminated '(*...' argument");
}
}
- } else {
- if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) {
+ } else {
+ if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) {
if (has_upper) {
vFAIL("Unterminated verb pattern");
}
vFAIL("Unterminated '(*...' construct");
}
}
- }
+ }
/* Here, we know that RExC_parse < RExC_end */
- switch ( *start_verb ) {
+ switch ( *start_verb ) {
case 'A': /* (*ACCEPT) */
if ( memEQs(start_verb, verb_len,"ACCEPT") ) {
- op = ACCEPT;
- internal_argval = RExC_nestroot;
- }
- break;
+ op = ACCEPT;
+ internal_argval = RExC_nestroot;
+ }
+ break;
case 'C': /* (*COMMIT) */
if ( memEQs(start_verb, verb_len,"COMMIT") )
op = COMMIT;
break;
case 'F': /* (*FAIL) */
if ( verb_len==1 || memEQs(start_verb, verb_len,"FAIL") ) {
- op = OPFAIL;
- }
- break;
+ op = OPFAIL;
+ }
+ break;
case ':': /* (*:NAME) */
- case 'M': /* (*MARK:NAME) */
- if ( verb_len==0 || memEQs(start_verb, verb_len,"MARK") ) {
+ case 'M': /* (*MARK:NAME) */
+ if ( verb_len==0 || memEQs(start_verb, verb_len,"MARK") ) {
op = MARKPOINT;
arg_required = 1;
}
goto no_colon;
}
- RExC_parse = start_arg;
+ RExC_parse_set(start_arg);
if (RExC_in_script_run) {
break;
lookbehind_alpha_assertions:
- RExC_seen |= REG_LOOKBEHIND_SEEN;
+ seen_flag_set = REG_LOOKBEHIND_SEEN;
/*FALLTHROUGH*/
alpha_assertions:
- RExC_in_lookaround++;
- RExC_seen_zerolen++;
-
- if (! start_arg) {
+ if ( !start_arg ) {
goto no_colon;
}
- /* An empty negative lookahead assertion simply is failure */
- if (paren == 'A' && RExC_parse == start_arg) {
- ret=reganode(pRExC_state, OPFAIL, 0);
- nextchar(pRExC_state);
- return ret;
- }
+ if ( RExC_parse == start_arg ) {
+ if ( paren == 'A' || paren == 'B' ) {
+ /* An empty negative lookaround assertion is failure.
+ * See also: S_reg_la_OPFAIL() */
- RExC_parse = start_arg;
+ /* Note: OPFAIL is *not* zerolen. */
+ ret = reg1node(pRExC_state, OPFAIL, 0);
+ nextchar(pRExC_state);
+ return ret;
+ }
+ else
+ if ( paren == 'a' || paren == 'b' ) {
+ /* An empty positive lookaround assertion is success.
+ * See also: S_reg_la_NOTHING() */
+
+ /* Note: NOTHING is zerolen, so increment here */
+ RExC_seen_zerolen++;
+ ret = reg_node(pRExC_state, NOTHING);
+ nextchar(pRExC_state);
+ return ret;
+ }
+ }
+
+ RExC_seen_zerolen++;
+ RExC_in_lookaround++;
+ RExC_seen |= seen_flag_set;
+
+ RExC_parse_set(start_arg);
goto parse_rest;
no_colon:
- vFAIL2utf8f(
- "'(*%" UTF8f "' requires a terminating ':'",
- UTF8fARG(UTF, verb_len, start_verb));
- NOT_REACHED; /*NOTREACHED*/
-
- } /* End of switch */
- if ( ! op ) {
- RExC_parse += UTF
- ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
- : 1;
- if (has_upper || verb_len == 0) {
- vFAIL2utf8f(
- "Unknown verb pattern '%" UTF8f "'",
+ vFAIL2utf8f( "'(*%" UTF8f "' requires a terminating ':'",
UTF8fARG(UTF, verb_len, start_verb));
+ NOT_REACHED; /*NOTREACHED*/
+
+ } /* End of switch */
+ if ( ! op ) {
+ RExC_parse_inc_safe();
+ if (has_upper || verb_len == 0) {
+ vFAIL2utf8f( "Unknown verb pattern '%" UTF8f "'",
+ UTF8fARG(UTF, verb_len, start_verb));
}
else {
- vFAIL2utf8f(
- "Unknown '(*...)' construct '%" UTF8f "'",
- UTF8fARG(UTF, verb_len, start_verb));
+ vFAIL2utf8f( "Unknown '(*...)' construct '%" UTF8f "'",
+ UTF8fARG(UTF, verb_len, start_verb));
}
- }
+ }
if ( RExC_parse == start_arg ) {
start_arg = NULL;
}
if ( arg_required && !start_arg ) {
- vFAIL3("Verb pattern '%.*s' has a mandatory argument",
+ vFAIL3( "Verb pattern '%.*s' has a mandatory argument",
(int) verb_len, start_verb);
}
if (internal_argval == -1) {
- ret = reganode(pRExC_state, op, 0);
+ ret = reg1node(pRExC_state, op, 0);
} else {
- ret = reg2Lanode(pRExC_state, op, 0, internal_argval);
+ ret = reg2node(pRExC_state, op, 0, internal_argval);
}
RExC_seen |= REG_VERBARG_SEEN;
if (start_arg) {
- SV *sv = newSVpvn( start_arg,
- RExC_parse - start_arg);
- ARG(REGNODE_p(ret)) = add_data( pRExC_state,
+ SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
+ ARG1u(REGNODE_p(ret)) = reg_add_data( pRExC_state,
STR_WITH_LEN("S"));
- RExC_rxi->data->data[ARG(REGNODE_p(ret))]=(void*)sv;
+ RExC_rxi->data->data[ARG1u(REGNODE_p(ret))]=(void*)sv;
FLAGS(REGNODE_p(ret)) = 1;
} else {
FLAGS(REGNODE_p(ret)) = 0;
}
if ( internal_argval != -1 )
- ARG2L_SET(REGNODE_p(ret), internal_argval);
- nextchar(pRExC_state);
- return ret;
+ ARG2i_SET(REGNODE_p(ret), internal_argval);
+ nextchar(pRExC_state);
+ return ret;
}
else if (*RExC_parse == '?') { /* (?...) */
- bool is_logical = 0;
- const char * const seqstart = RExC_parse;
+ handle_qmark:
+ ; /* make sure the label has a statement associated with it*/
+ bool is_logical = 0, is_optimistic = 0;
+ const char * const seqstart = RExC_parse;
const char * endptr;
const char non_existent_group_msg[]
= "Reference to nonexistent group";
const char impossible_group[] = "Invalid reference to group";
if (has_intervening_patws) {
- RExC_parse++;
+ RExC_parse_inc_by(1);
vFAIL("In '(?...)', the '(' and '?' must be adjacent");
}
- RExC_parse++; /* past the '?' */
- paren = *RExC_parse; /* might be a trailing NUL, if not
- well-formed */
- RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
+ RExC_parse_inc_by(1); /* past the '?' */
+ if (!fake_eval) {
+ paren = *RExC_parse; /* might be a trailing NUL, if not
+ well-formed */
+ is_optimistic = 0;
+ } else {
+ is_optimistic = 1;
+ paren = fake_eval;
+ }
+ RExC_parse_inc();
if (RExC_parse > RExC_end) {
paren = '\0';
}
- ret = 0; /* For look-ahead/behind. */
- switch (paren) {
+ ret = 0; /* For look-ahead/behind. */
+ switch (paren) {
- case 'P': /* (?P...) variants for those used to PCRE/Python */
- paren = *RExC_parse;
- if ( paren == '<') { /* (?P<...>) named capture */
- RExC_parse++;
+ case 'P': /* (?P...) variants for those used to PCRE/Python */
+ paren = *RExC_parse;
+ if ( paren == '<') { /* (?P<...>) named capture */
+ RExC_parse_inc_by(1);
if (RExC_parse >= RExC_end) {
vFAIL("Sequence (?P<... not terminated");
}
- goto named_capture;
+ goto named_capture;
}
else if (paren == '>') { /* (?P>name) named recursion */
- RExC_parse++;
+ RExC_parse_inc_by(1);
if (RExC_parse >= RExC_end) {
vFAIL("Sequence (?P>... not terminated");
}
goto named_recursion;
}
else if (paren == '=') { /* (?P=...) named backref */
- RExC_parse++;
+ RExC_parse_inc_by(1);
return handle_named_backref(pRExC_state, flagp,
- parse_start, ')');
+ segment_parse_start, ')');
}
- RExC_parse += SKIP_IF_CHAR(RExC_parse, RExC_end);
+ RExC_parse_inc_if_char();
/* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
- vFAIL3("Sequence (%.*s...) not recognized",
+ vFAIL3("Sequence (%.*s...) not recognized",
(int) (RExC_parse - seqstart), seqstart);
- NOT_REACHED; /*NOTREACHED*/
+ NOT_REACHED; /*NOTREACHED*/
case '<': /* (?<...) */
/* If you want to support (?<*...), first reconcile with GH #17363 */
- if (*RExC_parse == '!')
- paren = ',';
- else if (*RExC_parse != '=')
+ if (*RExC_parse == '!') {
+ paren = ','; /* negative lookbehind (?<! ... ) */
+ RExC_parse_inc_by(1);
+ if ((ret= reg_la_OPFAIL(pRExC_state,REG_LB_SEEN,"?<!")))
+ return ret;
+ break;
+ }
+ else
+ if (*RExC_parse == '=') {
+ /* paren = '<' - negative lookahead (?<= ... ) */
+ RExC_parse_inc_by(1);
+ if ((ret= reg_la_NOTHING(pRExC_state,REG_LB_SEEN,"?<=")))
+ return ret;
+ break;
+ }
+ else
named_capture:
- { /* (?<...>) */
- char *name_start;
- SV *svname;
- paren= '>';
+ { /* (?<...>) */
+ char *name_start;
+ SV *svname;
+ paren= '>';
/* FALLTHROUGH */
case '\'': /* (?'...') */
name_start = RExC_parse;
svname = reg_scan_name(pRExC_state, REG_RSN_RETURN_NAME);
- if ( RExC_parse == name_start
+ if ( RExC_parse == name_start
|| RExC_parse >= RExC_end
|| *RExC_parse != paren)
{
- vFAIL2("Sequence (?%c... not terminated",
- paren=='>' ? '<' : (char) paren);
+ vFAIL2("Sequence (?%c... not terminated",
+ paren=='>' ? '<' : (char) paren);
}
- {
- HE *he_str;
- SV *sv_dat = NULL;
+ {
+ HE *he_str;
+ SV *sv_dat = NULL;
if (!svname) /* shouldn't happen */
Perl_croak(aTHX_
"panic: reg_scan_name returned NULL");
SvIV_set(sv_dat, 1);
}
#ifdef DEBUGGING
- /* Yes this does cause a memory leak in debugging Perls
- * */
+ /* No, this does not cause a memory leak under
+ * debugging. RExC_paren_name_list is freed later
+ * on in the dump process. - Yves
+ */
if (!av_store(RExC_paren_name_list,
RExC_npar, SvREFCNT_inc_NN(svname)))
SvREFCNT_dec_NN(svname);
#endif
- /*sv_dump(sv_dat);*/
}
nextchar(pRExC_state);
- paren = 1;
- goto capturing_parens;
- }
-
- RExC_seen |= REG_LOOKBEHIND_SEEN;
- RExC_in_lookaround++;
- RExC_parse++;
- if (RExC_parse >= RExC_end) {
- vFAIL("Sequence (?... not terminated");
+ paren = 1;
+ goto capturing_parens;
}
- RExC_seen_zerolen++;
+ NOT_REACHED; /*NOTREACHED*/
+ case '=': /* (?=...) */
+ if ((ret= reg_la_NOTHING(pRExC_state, 0, "?=")))
+ return ret;
break;
- case '=': /* (?=...) */
- RExC_seen_zerolen++;
- RExC_in_lookaround++;
+ case '!': /* (?!...) */
+ if ((ret= reg_la_OPFAIL(pRExC_state, 0, "?!")))
+ return ret;
break;
- case '!': /* (?!...) */
- RExC_seen_zerolen++;
- /* check if we're really just a "FAIL" assertion */
- skip_to_be_ignored_text(pRExC_state, &RExC_parse,
- FALSE /* Don't force to /x */ );
- if (*RExC_parse == ')') {
- ret=reganode(pRExC_state, OPFAIL, 0);
- nextchar(pRExC_state);
- return ret;
- }
- RExC_in_lookaround++;
- break;
- case '|': /* (?|...) */
- /* branch reset, behave like a (?:...) except that
- buffers in alternations share the same numbers */
- paren = ':';
- after_freeze = freeze_paren = RExC_npar;
+ case '|': /* (?|...) */
+ /* branch reset, behave like a (?:...) except that
+ buffers in alternations share the same numbers */
+ paren = ':';
+ after_freeze = freeze_paren = RExC_logical_npar;
/* XXX This construct currently requires an extra pass.
* Investigation would be required to see if that could be
* changed */
REQUIRE_PARENS_PASS;
- break;
- case ':': /* (?:...) */
- case '>': /* (?>...) */
- break;
- case '$': /* (?$...) */
- case '@': /* (?@...) */
- vFAIL2("Sequence (?%c...) not implemented", (int)paren);
- break;
- case '0' : /* (?0) */
- case 'R' : /* (?R) */
+ break;
+ case ':': /* (?:...) */
+ case '>': /* (?>...) */
+ break;
+ case '$': /* (?$...) */
+ case '@': /* (?@...) */
+ vFAIL2("Sequence (?%c...) not implemented", (int)paren);
+ break;
+ case '0' : /* (?0) */
+ case 'R' : /* (?R) */
if (RExC_parse == RExC_end || *RExC_parse != ')')
- FAIL("Sequence (?R) not terminated");
+ FAIL("Sequence (?R) not terminated");
num = 0;
RExC_seen |= REG_RECURSE_SEEN;
* It probably could be changed */
REQUIRE_PARENS_PASS;
- *flagp |= POSTPONED;
+ *flagp |= POSTPONED;
goto gen_recurse_regop;
- /*notreached*/
+ /*notreached*/
/* named and numeric backreferences */
case '&': /* (?&NAME) */
- parse_start = RExC_parse - 1;
+ segment_parse_start = RExC_parse - 1;
named_recursion:
{
SV *sv_dat = reg_scan_name(pRExC_state,
/* NOTREACHED */
case '+':
if (! inRANGE(RExC_parse[0], '1', '9')) {
- RExC_parse++;
+ RExC_parse_inc_by(1);
vFAIL("Illegal pattern");
}
goto parse_recursion;
}
/* FALLTHROUGH */
case '1': case '2': case '3': case '4': /* (?1) */
- case '5': case '6': case '7': case '8': case '9':
- RExC_parse = (char *) seqstart + 1; /* Point to the digit */
+ case '5': case '6': case '7': case '8': case '9':
+ RExC_parse_set((char *) seqstart + 1); /* Point to the digit */
parse_recursion:
{
bool is_neg = FALSE;
UV unum;
- parse_start = RExC_parse - 1; /* MJD */
+ segment_parse_start = RExC_parse - 1;
if (*RExC_parse == '-') {
- RExC_parse++;
+ RExC_parse_inc_by(1);
is_neg = TRUE;
}
endptr = RExC_end;
&& unum <= I32_MAX
) {
num = (I32)unum;
- RExC_parse = (char*)endptr;
+ RExC_parse_set((char*)endptr);
}
else { /* Overflow, or something like that. Position
beyond all digits for the message */
while (RExC_parse < RExC_end && isDIGIT(*RExC_parse)) {
- RExC_parse++;
+ RExC_parse_inc_by(1);
}
vFAIL(impossible_group);
}
num = -num;
}
}
- if (*RExC_parse!=')')
- vFAIL("Expecting close bracket");
+ if (*RExC_parse!=')')
+ vFAIL("Expecting close bracket");
- gen_recurse_regop:
if (paren == '-' || paren == '+') {
/* Don't overflow */
if (UNLIKELY(I32_MAX - RExC_npar < num)) {
- RExC_parse++;
+ RExC_parse_inc_by(1);
vFAIL(impossible_group);
}
num += RExC_npar;
if (paren == '-' && num < 1) {
- RExC_parse++;
+ RExC_parse_inc_by(1);
+ vFAIL(non_existent_group_msg);
+ }
+ }
+ else
+ if (num && num < RExC_logical_npar) {
+ num = RExC_logical_to_parno[num];
+ }
+ else
+ if (ALL_PARENS_COUNTED) {
+ if (num < RExC_logical_total_parens) {
+ num = RExC_logical_to_parno[num];
+ }
+ else {
+ RExC_parse_inc_by(1);
vFAIL(non_existent_group_msg);
}
}
+ else {
+ REQUIRE_PARENS_PASS;
+ }
+
+ gen_recurse_regop:
if (num >= RExC_npar) {
/* It might be a forward reference; we can't fail until we
* then reparsing */
if (ALL_PARENS_COUNTED) {
if (num >= RExC_total_parens) {
- RExC_parse++;
+ RExC_parse_inc_by(1);
vFAIL(non_existent_group_msg);
}
}
}
/* We keep track how many GOSUB items we have produced.
- To start off the ARG2L() of the GOSUB holds its "id",
+ To start off the ARG2i() of the GOSUB holds its "id",
which is used later in conjunction with RExC_recurse
to calculate the offset we need to jump for the GOSUB,
which it will store in the final representation.
We have to defer the actual calculation until much later
as the regop may move.
*/
- ret = reg2Lanode(pRExC_state, GOSUB, num, RExC_recurse_count);
+ ret = reg2node(pRExC_state, GOSUB, num, RExC_recurse_count);
RExC_recurse_count++;
DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
"%*s%*s Recurse #%" UVuf " to %" IVdf "\n",
22, "| |", (int)(depth * 2 + 1), "",
- (UV)ARG(REGNODE_p(ret)),
- (IV)ARG2L(REGNODE_p(ret))));
+ (UV)ARG1u(REGNODE_p(ret)),
+ (IV)ARG2i(REGNODE_p(ret))));
RExC_seen |= REG_RECURSE_SEEN;
- Set_Node_Length(REGNODE_p(ret),
- 1 + regarglen[OP(REGNODE_p(ret))]); /* MJD */
- Set_Node_Offset(REGNODE_p(ret), parse_start); /* MJD */
-
*flagp |= POSTPONED;
assert(*RExC_parse == ')');
nextchar(pRExC_state);
/* NOTREACHED */
- case '?': /* (??...) */
- is_logical = 1;
- if (*RExC_parse != '{') {
- RExC_parse += SKIP_IF_CHAR(RExC_parse, RExC_end);
+ case '?': /* (??...) */
+ is_logical = 1;
+ if (*RExC_parse != '{') {
+ RExC_parse_inc_if_char();
/* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
vFAIL2utf8f(
"Sequence (%" UTF8f "...) not recognized",
UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
- NOT_REACHED; /*NOTREACHED*/
- }
- *flagp |= POSTPONED;
- paren = '{';
- RExC_parse++;
- /* FALLTHROUGH */
- case '{': /* (?{...}) */
- {
- U32 n = 0;
- struct reg_code_block *cb;
+ NOT_REACHED; /*NOTREACHED*/
+ }
+ *flagp |= POSTPONED;
+ paren = '{';
+ RExC_parse_inc_by(1);
+ /* FALLTHROUGH */
+ case '{': /* (?{...}) */
+ {
+ U32 n = 0;
+ struct reg_code_block *cb;
OP * o;
- RExC_seen_zerolen++;
+ RExC_seen_zerolen++;
- if ( !pRExC_state->code_blocks
- || pRExC_state->code_index
+ if ( !pRExC_state->code_blocks
+ || pRExC_state->code_index
>= pRExC_state->code_blocks->count
- || pRExC_state->code_blocks->cb[pRExC_state->code_index].start
- != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
- - RExC_start)
- ) {
- if (RExC_pm_flags & PMf_USE_RE_EVAL)
- FAIL("panic: Sequence (?{...}): no code block found\n");
- FAIL("Eval-group not allowed at runtime, use re 'eval'");
- }
- /* this is a pre-compiled code block (?{...}) */
- cb = &pRExC_state->code_blocks->cb[pRExC_state->code_index];
- RExC_parse = RExC_start + cb->end;
- o = cb->block;
+ || pRExC_state->code_blocks->cb[pRExC_state->code_index].start
+ != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
+ - RExC_start)
+ ) {
+ if (RExC_pm_flags & PMf_USE_RE_EVAL)
+ FAIL("panic: Sequence (?{...}): no code block found\n");
+ FAIL("Eval-group not allowed at runtime, use re 'eval'");
+ }
+ /* this is a pre-compiled code block (?{...}) */
+ cb = &pRExC_state->code_blocks->cb[pRExC_state->code_index];
+ RExC_parse_set(RExC_start + cb->end);
+ o = cb->block;
if (cb->src_regex) {
- n = add_data(pRExC_state, STR_WITH_LEN("rl"));
+ n = reg_add_data(pRExC_state, STR_WITH_LEN("rl"));
RExC_rxi->data->data[n] =
(void*)SvREFCNT_inc((SV*)cb->src_regex);
RExC_rxi->data->data[n+1] = (void*)o;
}
else {
- n = add_data(pRExC_state,
+ n = reg_add_data(pRExC_state,
(RExC_pm_flags & PMf_HAS_CV) ? "L" : "l", 1);
RExC_rxi->data->data[n] = (void*)o;
}
- pRExC_state->code_index++;
- nextchar(pRExC_state);
+ pRExC_state->code_index++;
+ nextchar(pRExC_state);
+ if (!is_optimistic)
+ RExC_seen |= REG_PESSIMIZE_SEEN;
- if (is_logical) {
+ if (is_logical) {
regnode_offset eval;
- ret = reg_node(pRExC_state, LOGICAL);
+ ret = reg_node(pRExC_state, LOGICAL);
+ FLAGS(REGNODE_p(ret)) = 2;
- eval = reg2Lanode(pRExC_state, EVAL,
+ eval = reg2node(pRExC_state, EVAL,
n,
/* for later propagation into (??{})
* return value */
RExC_flags & RXf_PMf_COMPILETIME
);
- FLAGS(REGNODE_p(ret)) = 2;
+ FLAGS(REGNODE_p(eval)) = is_optimistic * EVAL_OPTIMISTIC_FLAG;
if (! REGTAIL(pRExC_state, ret, eval)) {
REQUIRE_BRANCHJ(flagp, 0);
}
- /* deal with the length of this later - MJD */
- return ret;
- }
- ret = reg2Lanode(pRExC_state, EVAL, n, 0);
- Set_Node_Length(REGNODE_p(ret), RExC_parse - parse_start + 1);
- Set_Node_Offset(REGNODE_p(ret), parse_start);
- return ret;
- }
- case '(': /* (?(?{...})...) and (?(?=...)...) */
- {
- int is_define= 0;
+ return ret;
+ }
+ ret = reg2node(pRExC_state, EVAL, n, 0);
+ FLAGS(REGNODE_p(ret)) = is_optimistic * EVAL_OPTIMISTIC_FLAG;
+
+ return ret;
+ }
+ case '(': /* (?(?{...})...) and (?(?=...)...) */
+ {
+ int is_define= 0;
const int DEFINE_len = sizeof("DEFINE") - 1;
- if ( RExC_parse < RExC_end - 1
+ if ( RExC_parse < RExC_end - 1
&& ( ( RExC_parse[0] == '?' /* (?(?...)) */
&& ( RExC_parse[1] == '='
|| RExC_parse[1] == '!'
|| RExC_parse[1] == '<'
|| RExC_parse[1] == '{'))
- || ( RExC_parse[0] == '*' /* (?(*...)) */
- && ( memBEGINs(RExC_parse + 1,
+ || ( RExC_parse[0] == '*' /* (?(*...)) */
+ && ( RExC_parse[1] == '{'
+ || ( memBEGINs(RExC_parse + 1,
(Size_t) (RExC_end - (RExC_parse + 1)),
"pla:")
|| memBEGINs(RExC_parse + 1,
"negative_lookahead:")
|| memBEGINs(RExC_parse + 1,
(Size_t) (RExC_end - (RExC_parse + 1)),
- "negative_lookbehind:"))))
+ "negative_lookbehind:")))))
) { /* Lookahead or eval. */
I32 flag;
regnode_offset tail;
}
goto insert_if;
}
- else if ( RExC_parse[0] == '<' /* (?(<NAME>)...) */
- || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
- {
- char ch = RExC_parse[0] == '<' ? '>' : '\'';
- char *name_start= RExC_parse++;
- U32 num = 0;
- SV *sv_dat=reg_scan_name(pRExC_state, REG_RSN_RETURN_DATA);
- if ( RExC_parse == name_start
+ else if ( RExC_parse[0] == '<' /* (?(<NAME>)...) */
+ || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
+ {
+ char ch = RExC_parse[0] == '<' ? '>' : '\'';
+ char *name_start= RExC_parse;
+ RExC_parse_inc_by(1);
+ U32 num = 0;
+ SV *sv_dat=reg_scan_name(pRExC_state, REG_RSN_RETURN_DATA);
+ if ( RExC_parse == name_start
|| RExC_parse >= RExC_end
|| *RExC_parse != ch)
{
vFAIL2("Sequence (?(%c... not terminated",
(ch == '>' ? '<' : ch));
}
- RExC_parse++;
+ RExC_parse_inc_by(1);
if (sv_dat) {
- num = add_data( pRExC_state, STR_WITH_LEN("S"));
+ num = reg_add_data( pRExC_state, STR_WITH_LEN("S"));
RExC_rxi->data->data[num]=(void*)sv_dat;
SvREFCNT_inc_simple_void_NN(sv_dat);
}
- ret = reganode(pRExC_state, GROUPPN, num);
+ ret = reg1node(pRExC_state, GROUPPN, num);
goto insert_if_check_paren;
- }
- else if (memBEGINs(RExC_parse,
+ }
+ else if (memBEGINs(RExC_parse,
(STRLEN) (RExC_end - RExC_parse),
"DEFINE"))
{
- ret = reganode(pRExC_state, DEFINEP, 0);
- RExC_parse += DEFINE_len;
- is_define = 1;
- goto insert_if_check_paren;
- }
- else if (RExC_parse[0] == 'R') {
- RExC_parse++;
+ ret = reg1node(pRExC_state, DEFINEP, 0);
+ RExC_parse_inc_by(DEFINE_len);
+ is_define = 1;
+ goto insert_if_check_paren;
+ }
+ else if (RExC_parse[0] == 'R') {
+ RExC_parse_inc_by(1);
/* parno == 0 => /(?(R)YES|NO)/ "in any form of recursion OR eval"
* parno == 1 => /(?(R0)YES|NO)/ "in GOSUB (?0) / (?R)"
* parno == 2 => /(?(R1)YES|NO)/ "in GOSUB (?1) (parno-1)"
*/
- parno = 0;
+ parno = 0;
if (RExC_parse[0] == '0') {
parno = 1;
- RExC_parse++;
+ RExC_parse_inc_by(1);
}
else if (inRANGE(RExC_parse[0], '1', '9')) {
UV uv;
&& uv <= I32_MAX
) {
parno = (I32)uv + 1;
- RExC_parse = (char*)endptr;
+ RExC_parse_set((char*)endptr);
}
/* else "Switch condition not recognized" below */
- } else if (RExC_parse[0] == '&') {
- SV *sv_dat;
- RExC_parse++;
- sv_dat = reg_scan_name(pRExC_state,
+ } else if (RExC_parse[0] == '&') {
+ SV *sv_dat;
+ RExC_parse_inc_by(1);
+ sv_dat = reg_scan_name(pRExC_state,
REG_RSN_RETURN_DATA);
if (sv_dat)
parno = 1 + *((I32 *)SvPVX(sv_dat));
- }
- ret = reganode(pRExC_state, INSUBP, parno);
- goto insert_if_check_paren;
- }
+ }
+ ret = reg1node(pRExC_state, INSUBP, parno);
+ goto insert_if_check_paren;
+ }
else if (inRANGE(RExC_parse[0], '1', '9')) {
/* (?(1)...) */
- char c;
+ char c;
UV uv;
endptr = RExC_end;
if (grok_atoUV(RExC_parse, &uv, &endptr)
&& uv <= I32_MAX
) {
parno = (I32)uv;
- RExC_parse = (char*)endptr;
+ RExC_parse_set((char*)endptr);
}
else {
vFAIL("panic: grok_atoUV returned FALSE");
}
- ret = reganode(pRExC_state, GROUPP, parno);
+ ret = reg1node(pRExC_state, GROUPP, parno);
insert_if_check_paren:
- if (UCHARAT(RExC_parse) != ')') {
- RExC_parse += UTF
- ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
- : 1;
- vFAIL("Switch condition not recognized");
- }
- nextchar(pRExC_state);
- insert_if:
- if (! REGTAIL(pRExC_state, ret, reganode(pRExC_state,
+ if (UCHARAT(RExC_parse) != ')') {
+ RExC_parse_inc_safe();
+ vFAIL("Switch condition not recognized");
+ }
+ nextchar(pRExC_state);
+ insert_if:
+ if (! REGTAIL(pRExC_state, ret, reg1node(pRExC_state,
IFTHEN, 0)))
{
REQUIRE_BRANCHJ(flagp, 0);
}
br = regbranch(pRExC_state, &flags, 1, depth+1);
- if (br == 0) {
+ if (br == 0) {
RETURN_FAIL_ON_RESTART(flags,flagp);
FAIL2("panic: regbranch returned failure, flags=%#" UVxf,
(UV) flags);
} else
- if (! REGTAIL(pRExC_state, br, reganode(pRExC_state,
+ if (! REGTAIL(pRExC_state, br, reg1node(pRExC_state,
LONGJMP, 0)))
{
REQUIRE_BRANCHJ(flagp, 0);
}
- c = UCHARAT(RExC_parse);
+ c = UCHARAT(RExC_parse);
nextchar(pRExC_state);
- if (flags&HASWIDTH)
- *flagp |= HASWIDTH;
- if (c == '|') {
- if (is_define)
- vFAIL("(?(DEFINE)....) does not allow branches");
+ if (flags&HASWIDTH)
+ *flagp |= HASWIDTH;
+ if (c == '|') {
+ if (is_define)
+ vFAIL("(?(DEFINE)....) does not allow branches");
/* Fake one for optimizer. */
- lastbr = reganode(pRExC_state, IFTHEN, 0);
+ lastbr = reg1node(pRExC_state, IFTHEN, 0);
if (!regbranch(pRExC_state, &flags, 1, depth+1)) {
RETURN_FAIL_ON_RESTART(flags, flagp);
REQUIRE_BRANCHJ(flagp, 0);
}
if (flags&HASWIDTH)
- *flagp |= HASWIDTH;
+ *flagp |= HASWIDTH;
c = UCHARAT(RExC_parse);
nextchar(pRExC_state);
- }
- else
- lastbr = 0;
+ }
+ else
+ lastbr = 0;
if (c != ')') {
if (RExC_parse >= RExC_end)
vFAIL("Switch (?(condition)... not terminated");
else
vFAIL("Switch (?(condition)... contains too many branches");
}
- ender = reg_node(pRExC_state, TAIL);
+ ender = reg_node(pRExC_state, TAIL);
if (! REGTAIL(pRExC_state, br, ender)) {
REQUIRE_BRANCHJ(flagp, 0);
}
- if (lastbr) {
+ if (lastbr) {
if (! REGTAIL(pRExC_state, lastbr, ender)) {
REQUIRE_BRANCHJ(flagp, 0);
}
if (! REGTAIL(pRExC_state,
REGNODE_OFFSET(
- NEXTOPER(
- NEXTOPER(REGNODE_p(lastbr)))),
+ REGNODE_AFTER(REGNODE_p(lastbr))),
ender))
{
REQUIRE_BRANCHJ(flagp, 0);
}
- }
- else
+ }
+ else
if (! REGTAIL(pRExC_state, ret, ender)) {
REQUIRE_BRANCHJ(flagp, 0);
}
For large programs it seems to be required
but I can't figure out why. -- dmq*/
#endif
- return ret;
- }
- RExC_parse += UTF
- ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
- : 1;
+ return ret;
+ }
+ RExC_parse_inc_safe();
vFAIL("Unknown switch condition (?(...))");
- }
- case '[': /* (?[ ... ]) */
- return handle_regex_sets(pRExC_state, NULL, flagp, depth+1,
- oregcomp_parse);
+ }
+ case '[': /* (?[ ... ]) */
+ return handle_regex_sets(pRExC_state, NULL, flagp, depth+1);
case 0: /* A NUL */
- RExC_parse--; /* for vFAIL to print correctly */
+ RExC_parse--; /* for vFAIL to print correctly */
vFAIL("Sequence (? incomplete");
break;
}
/* FALLTHROUGH */
case '*': /* If you want to support (?*...), first reconcile with GH #17363 */
- /* FALLTHROUGH */
- default: /* e.g., (?i) */
- RExC_parse = (char *) seqstart + 1;
+ /* FALLTHROUGH */
+ default: /* e.g., (?i) */
+ RExC_parse_set((char *) seqstart + 1);
parse_flags:
- parse_lparen_question_flags(pRExC_state);
+ parse_lparen_question_flags(pRExC_state);
if (UCHARAT(RExC_parse) != ':') {
if (RExC_parse < RExC_end)
nextchar(pRExC_state);
ret = 0;
goto parse_rest;
} /* end switch */
- }
+ }
else if (!(RExC_flags & RXf_PMf_NOCAPTURE)) { /* (...) */
- capturing_parens:
- parno = RExC_npar;
- RExC_npar++;
+ capturing_parens:
+ parno = RExC_npar;
+ RExC_npar++;
+ if (RExC_npar >= U16_MAX)
+ FAIL2("Too many capture groups (limit is %" UVuf ")", (UV)RExC_npar);
+
+ logical_parno = RExC_logical_npar;
+ RExC_logical_npar++;
if (! ALL_PARENS_COUNTED) {
/* If we are in our first pass through (and maybe only pass),
* we need to allocate memory for the capturing parentheses
* */
Newxz(RExC_close_parens, RExC_parens_buf_size,
regnode_offset);
- /* we dont know where end op starts yet, so we dont need to
+ /* we don't know where end op starts yet, so we don't need to
* set RExC_close_parens[0] like we do RExC_open_parens[0]
* above */
+
+ Newxz(RExC_logical_to_parno, RExC_parens_buf_size, I32);
+ Newxz(RExC_parno_to_logical, RExC_parens_buf_size, I32);
}
else if (RExC_npar > RExC_parens_buf_size) {
I32 old_size = RExC_parens_buf_size;
regnode_offset);
Zero(RExC_close_parens + old_size,
RExC_parens_buf_size - old_size, regnode_offset);
+
+ Renew(RExC_logical_to_parno, RExC_parens_buf_size, I32);
+ Zero(RExC_logical_to_parno + old_size,
+ RExC_parens_buf_size - old_size, I32);
+
+ Renew(RExC_parno_to_logical, RExC_parens_buf_size, I32);
+ Zero(RExC_parno_to_logical + old_size,
+ RExC_parens_buf_size - old_size, I32);
}
}
- ret = reganode(pRExC_state, OPEN, parno);
+ ret = reg1node(pRExC_state, OPEN, parno);
if (!RExC_nestroot)
RExC_nestroot = parno;
if (RExC_open_parens && !RExC_open_parens[parno])
(IV)parno, ret));
RExC_open_parens[parno]= ret;
}
-
- Set_Node_Length(REGNODE_p(ret), 1); /* MJD */
- Set_Node_Offset(REGNODE_p(ret), RExC_parse); /* MJD */
- is_open = 1;
- } else {
+ if (RExC_parno_to_logical) {
+ RExC_parno_to_logical[parno] = logical_parno;
+ if (RExC_logical_to_parno && !RExC_logical_to_parno[logical_parno])
+ RExC_logical_to_parno[logical_parno] = parno;
+ }
+ is_open = 1;
+ } else {
/* with RXf_PMf_NOCAPTURE treat (...) as (?:...) */
paren = ':';
- ret = 0;
+ ret = 0;
}
}
else /* ! paren */
- ret = 0;
+ ret = 0;
parse_rest:
/* Pick up the branches, linking them together. */
- parse_start = RExC_parse; /* MJD */
+ segment_parse_start = RExC_parse;
+ I32 npar_before_regbranch = RExC_npar - 1;
br = regbranch(pRExC_state, &flags, 1, depth+1);
/* branch_len = (paren != 0); */
FAIL2("panic: regbranch returned failure, flags=%#" UVxf, (UV) flags);
}
if (*RExC_parse == '|') {
- if (RExC_use_BRANCHJ) {
- reginsert(pRExC_state, BRANCHJ, br, depth+1);
- }
- else { /* MJD */
- reginsert(pRExC_state, BRANCH, br, depth+1);
- Set_Node_Length(REGNODE_p(br), paren != 0);
- Set_Node_Offset_To_R(br, parse_start-RExC_start);
- }
- have_branch = 1;
+ if (RExC_use_BRANCHJ) {
+ reginsert(pRExC_state, BRANCHJ, br, depth+1);
+ ARG2a_SET(REGNODE_p(br), npar_before_regbranch);
+ ARG2b_SET(REGNODE_p(br), (U16)RExC_npar - 1);
+ }
+ else {
+ reginsert(pRExC_state, BRANCH, br, depth+1);
+ ARG1a_SET(REGNODE_p(br), (U16)npar_before_regbranch);
+ ARG1b_SET(REGNODE_p(br), (U16)RExC_npar - 1);
+ }
+ have_branch = 1;
}
else if (paren == ':') {
- *flagp |= flags&SIMPLE;
+ *flagp |= flags&SIMPLE;
}
if (is_open) { /* Starts with OPEN. */
if (! REGTAIL(pRExC_state, ret, br)) { /* OPEN -> first. */
}
}
else if (paren != '?') /* Not Conditional */
- ret = br;
+ ret = br;
*flagp |= flags & (HASWIDTH | POSTPONED);
lastbr = br;
while (*RExC_parse == '|') {
- if (RExC_use_BRANCHJ) {
+ if (RExC_use_BRANCHJ) {
bool shut_gcc_up;
- ender = reganode(pRExC_state, LONGJMP, 0);
+ ender = reg1node(pRExC_state, LONGJMP, 0);
/* Append to the previous. */
shut_gcc_up = REGTAIL(pRExC_state,
- REGNODE_OFFSET(NEXTOPER(NEXTOPER(REGNODE_p(lastbr)))),
+ REGNODE_OFFSET(REGNODE_AFTER(REGNODE_p(lastbr))),
ender);
PERL_UNUSED_VAR(shut_gcc_up);
- }
- nextchar(pRExC_state);
- if (freeze_paren) {
- if (RExC_npar > after_freeze)
- after_freeze = RExC_npar;
- RExC_npar = freeze_paren;
+ }
+ nextchar(pRExC_state);
+ if (freeze_paren) {
+ if (RExC_logical_npar > after_freeze)
+ after_freeze = RExC_logical_npar;
+ RExC_logical_npar = freeze_paren;
}
br = regbranch(pRExC_state, &flags, 0, depth+1);
- if (br == 0) {
+ if (br == 0) {
RETURN_FAIL_ON_RESTART(flags, flagp);
FAIL2("panic: regbranch returned failure, flags=%#" UVxf, (UV) flags);
}
if (! REGTAIL(pRExC_state, lastbr, br)) { /* BRANCH -> BRANCH. */
REQUIRE_BRANCHJ(flagp, 0);
}
- lastbr = br;
- *flagp |= flags & (HASWIDTH | POSTPONED);
+ assert(OP(REGNODE_p(br)) == BRANCH || OP(REGNODE_p(br))==BRANCHJ);
+ assert(OP(REGNODE_p(lastbr)) == BRANCH || OP(REGNODE_p(lastbr))==BRANCHJ);
+ if (OP(REGNODE_p(br)) == BRANCH) {
+ if (OP(REGNODE_p(lastbr)) == BRANCH)
+ ARG1b_SET(REGNODE_p(lastbr),ARG1a(REGNODE_p(br)));
+ else
+ ARG2b_SET(REGNODE_p(lastbr),ARG1a(REGNODE_p(br)));
+ }
+ else
+ if (OP(REGNODE_p(br)) == BRANCHJ) {
+ if (OP(REGNODE_p(lastbr)) == BRANCH)
+ ARG1b_SET(REGNODE_p(lastbr),ARG2a(REGNODE_p(br)));
+ else
+ ARG2b_SET(REGNODE_p(lastbr),ARG2a(REGNODE_p(br)));
+ }
+
+ lastbr = br;
+ *flagp |= flags & (HASWIDTH | POSTPONED);
}
if (have_branch || paren != ':') {
regnode * br;
- /* Make a closing node, and hook it on the end. */
- switch (paren) {
- case ':':
- ender = reg_node(pRExC_state, TAIL);
- break;
- case 1: case 2:
- ender = reganode(pRExC_state, CLOSE, parno);
+ /* Make a closing node, and hook it on the end. */
+ switch (paren) {
+ case ':':
+ ender = reg_node(pRExC_state, TAIL);
+ break;
+ case 1: case 2:
+ ender = reg1node(pRExC_state, CLOSE, parno);
if ( RExC_close_parens ) {
DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
"%*s%*s Setting close paren #%" IVdf " to %zu\n",
22, "| |", (int)(depth * 2 + 1), "",
(IV)parno, ender));
RExC_close_parens[parno]= ender;
- if (RExC_nestroot == parno)
- RExC_nestroot = 0;
- }
- Set_Node_Offset(REGNODE_p(ender), RExC_parse+1); /* MJD */
- Set_Node_Length(REGNODE_p(ender), 1); /* MJD */
- break;
- case 's':
- ender = reg_node(pRExC_state, SRCLOSE);
+ if (RExC_nestroot == parno)
+ RExC_nestroot = 0;
+ }
+ break;
+ case 's':
+ ender = reg_node(pRExC_state, SRCLOSE);
RExC_in_script_run = 0;
- break;
- case '<':
+ break;
+ /* LOOKBEHIND ops (not sure why these are duplicated - Yves) */
+ case 'b': /* (*positive_lookbehind: ... ) (*plb: ... ) */
+ case 'B': /* (*negative_lookbehind: ... ) (*nlb: ... ) */
+ case '<': /* (?<= ... ) */
+ case ',': /* (?<! ... ) */
+ *flagp &= ~HASWIDTH;
+ ender = reg_node(pRExC_state, LOOKBEHIND_END);
+ break;
+ /* LOOKAHEAD ops (not sure why these are duplicated - Yves) */
case 'a':
case 'A':
- case 'b':
- case 'B':
- case ',':
- case '=':
- case '!':
- *flagp &= ~HASWIDTH;
- /* FALLTHROUGH */
+ case '=':
+ case '!':
+ *flagp &= ~HASWIDTH;
+ /* FALLTHROUGH */
case 't': /* aTomic */
- case '>':
- ender = reg_node(pRExC_state, SUCCEED);
- break;
- case 0:
- ender = reg_node(pRExC_state, END);
+ case '>':
+ ender = reg_node(pRExC_state, SUCCEED);
+ break;
+ case 0:
+ ender = reg_node(pRExC_state, END);
assert(!RExC_end_op); /* there can only be one! */
RExC_end_op = REGNODE_p(ender);
if (RExC_close_parens) {
RExC_close_parens[0]= ender;
}
- break;
- }
+ break;
+ }
DEBUG_PARSE_r({
DEBUG_PARSE_MSG("lsbr");
regprop(RExC_rx, RExC_mysv1, REGNODE_p(lastbr), NULL, pRExC_state);
(IV)(ender - lastbr)
);
});
+ if (OP(REGNODE_p(lastbr)) == BRANCH) {
+ ARG1b_SET(REGNODE_p(lastbr),(U16)RExC_npar-1);
+ }
+ else
+ if (OP(REGNODE_p(lastbr)) == BRANCHJ) {
+ ARG2b_SET(REGNODE_p(lastbr),(U16)RExC_npar-1);
+ }
+
if (! REGTAIL(pRExC_state, lastbr, ender)) {
REQUIRE_BRANCHJ(flagp, 0);
}
- if (have_branch) {
+ if (have_branch) {
char is_nothing= 1;
- if (depth==1)
+ if (depth==1)
RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
- /* Hook the tails of the branches to the closing node. */
- for (br = REGNODE_p(ret); br; br = regnext(br)) {
- const U8 op = PL_regkind[OP(br)];
- if (op == BRANCH) {
+ /* Hook the tails of the branches to the closing node. */
+ for (br = REGNODE_p(ret); br; br = regnext(br)) {
+ const U8 op = REGNODE_TYPE(OP(br));
+ regnode *nextoper = REGNODE_AFTER(br);
+ if (op == BRANCH) {
if (! REGTAIL_STUDY(pRExC_state,
- REGNODE_OFFSET(NEXTOPER(br)),
+ REGNODE_OFFSET(nextoper),
ender))
{
REQUIRE_BRANCHJ(flagp, 0);
}
- if ( OP(NEXTOPER(br)) != NOTHING
- || regnext(NEXTOPER(br)) != REGNODE_p(ender))
+ if ( OP(nextoper) != NOTHING
+ || regnext(nextoper) != REGNODE_p(ender))
is_nothing= 0;
- }
- else if (op == BRANCHJ) {
+ }
+ else if (op == BRANCHJ) {
bool shut_gcc_up = REGTAIL_STUDY(pRExC_state,
- REGNODE_OFFSET(NEXTOPER(NEXTOPER(br))),
+ REGNODE_OFFSET(nextoper),
ender);
PERL_UNUSED_VAR(shut_gcc_up);
/* for now we always disable this optimisation * /
- if ( OP(NEXTOPER(NEXTOPER(br))) != NOTHING
- || regnext(NEXTOPER(NEXTOPER(br))) != REGNODE_p(ender))
+ regnode *nopr= REGNODE_AFTER_type(br,tregnode_BRANCHJ);
+ if ( OP(nopr) != NOTHING
+ || regnext(nopr) != REGNODE_p(ender))
*/
is_nothing= 0;
- }
- }
+ }
+ }
if (is_nothing) {
regnode * ret_as_regnode = REGNODE_p(ret);
- br= PL_regkind[OP(ret_as_regnode)] != BRANCH
+ br= REGNODE_TYPE(OP(ret_as_regnode)) != BRANCH
? regnext(ret_as_regnode)
: ret_as_regnode;
DEBUG_PARSE_r({
OP(br)= NOTHING;
if (OP(REGNODE_p(ender)) == TAIL) {
NEXT_OFF(br)= 0;
- RExC_emit= REGNODE_OFFSET(br) + 1;
+ RExC_emit= REGNODE_OFFSET(br) + NODE_STEP_REGNODE;
} else {
regnode *opt;
for ( opt= br + 1; opt < REGNODE_p(ender) ; opt++ )
NEXT_OFF(br)= REGNODE_p(ender) - br;
}
}
- }
+ }
}
{
static const char parens[] = "=!aA<,>Bbt";
/* flag below is set to 0 up through 'A'; 1 for larger */
- if (paren && (p = strchr(parens, paren))) {
- U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
- int flag = (p - parens) > 3;
+ if (paren && (p = strchr(parens, paren))) {
+ U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
+ int flag = (p - parens) > 3;
- if (paren == '>' || paren == 't') {
- node = SUSPEND, flag = 0;
+ if (paren == '>' || paren == 't') {
+ node = SUSPEND, flag = 0;
}
- reginsert(pRExC_state, node, ret, depth+1);
- Set_Node_Cur_Length(REGNODE_p(ret), parse_start);
- Set_Node_Offset(REGNODE_p(ret), parse_start + 1);
- FLAGS(REGNODE_p(ret)) = flag;
+ reginsert(pRExC_state, node, ret, depth+1);
+ FLAGS(REGNODE_p(ret)) = flag;
if (! REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL)))
{
REQUIRE_BRANCHJ(flagp, 0);
}
- }
+ }
}
/* Check for proper termination. */
if (paren) {
/* restore original flags, but keep (?p) and, if we've encountered
* something in the parse that changes /d rules into /u, keep the /u */
- RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
+ RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
if (DEPENDS_SEMANTICS && toUSE_UNI_CHARSET_NOT_DEPENDS) {
set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
}
- if (RExC_parse >= RExC_end || UCHARAT(RExC_parse) != ')') {
- RExC_parse = oregcomp_parse;
- vFAIL("Unmatched (");
- }
- nextchar(pRExC_state);
+ if (RExC_parse >= RExC_end || UCHARAT(RExC_parse) != ')') {
+ RExC_parse_set(reg_parse_start);
+ vFAIL("Unmatched (");
+ }
+ nextchar(pRExC_state);
}
else if (!paren && RExC_parse < RExC_end) {
- if (*RExC_parse == ')') {
- RExC_parse++;
- vFAIL("Unmatched )");
- }
- else
- FAIL("Junk on end of regexp"); /* "Can't happen". */
- NOT_REACHED; /* NOTREACHED */
+ if (*RExC_parse == ')') {
+ RExC_parse_inc_by(1);
+ vFAIL("Unmatched )");
+ }
+ else
+ FAIL("Junk on end of regexp"); /* "Can't happen". */
+ NOT_REACHED; /* NOTREACHED */
}
- if (after_freeze > RExC_npar)
- RExC_npar = after_freeze;
+ if (after_freeze > RExC_logical_npar)
+ RExC_logical_npar = after_freeze;
RExC_in_lookaround = was_in_lookaround;
-
+
return(ret);
}
regnode_offset ret;
regnode_offset chain = 0;
regnode_offset latest;
+ regnode *branch_node = NULL;
I32 flags = 0, c = 0;
DECLARE_AND_GET_RE_DEBUG_FLAGS;
DEBUG_PARSE("brnc");
if (first)
- ret = 0;
+ ret = 0;
else {
- if (RExC_use_BRANCHJ)
- ret = reganode(pRExC_state, BRANCHJ, 0);
- else {
- ret = reg_node(pRExC_state, BRANCH);
- Set_Node_Length(REGNODE_p(ret), 1);
+ if (RExC_use_BRANCHJ) {
+ ret = reg2node(pRExC_state, BRANCHJ, 0, 0);
+ branch_node = REGNODE_p(ret);
+ ARG2a_SET(branch_node, (U16)RExC_npar-1);
+ } else {
+ ret = reg1node(pRExC_state, BRANCH, 0);
+ branch_node = REGNODE_p(ret);
+ ARG1a_SET(branch_node, (U16)RExC_npar-1);
}
}
skip_to_be_ignored_text(pRExC_state, &RExC_parse,
FALSE /* Don't force to /x */ );
while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
- flags &= ~TRYAGAIN;
+ flags &= ~TRYAGAIN;
latest = regpiece(pRExC_state, &flags, depth+1);
- if (latest == 0) {
- if (flags & TRYAGAIN)
- continue;
+ if (latest == 0) {
+ if (flags & TRYAGAIN)
+ continue;
RETURN_FAIL_ON_RESTART(flags, flagp);
FAIL2("panic: regpiece returned failure, flags=%#" UVxf, (UV) flags);
- }
- else if (ret == 0)
+ }
+ else if (ret == 0)
ret = latest;
- *flagp |= flags&(HASWIDTH|POSTPONED);
- if (chain != 0) {
- /* FIXME adding one for every branch after the first is probably
- * excessive now we have TRIE support. (hv) */
- MARK_NAUGHTY(1);
+ *flagp |= flags&(HASWIDTH|POSTPONED);
+ if (chain != 0) {
+ /* FIXME adding one for every branch after the first is probably
+ * excessive now we have TRIE support. (hv) */
+ MARK_NAUGHTY(1);
if (! REGTAIL(pRExC_state, chain, latest)) {
/* XXX We could just redo this branch, but figuring out what
* bookkeeping needs to be reset is a pain, and it's likely
* that other branches that goto END will also be too large */
REQUIRE_BRANCHJ(flagp, 0);
}
- }
- chain = latest;
- c++;
+ }
+ chain = latest;
+ c++;
}
if (chain == 0) { /* Loop ran zero times. */
- chain = reg_node(pRExC_state, NOTHING);
- if (ret == 0)
- ret = chain;
+ chain = reg_node(pRExC_state, NOTHING);
+ if (ret == 0)
+ ret = chain;
}
if (c == 1) {
- *flagp |= flags&SIMPLE;
+ *flagp |= flags & SIMPLE;
}
-
return ret;
}
+#define RBRACE 0
+#define MIN_S 1
+#define MIN_E 2
+#define MAX_S 3
+#define MAX_E 4
+
+#ifndef PERL_IN_XSUB_RE
bool
Perl_regcurly(const char *s, const char *e, const char * result[5])
{
PERL_ARGS_ASSERT_REGCURLY;
if (s >= e || *s++ != '{')
- return FALSE;
+ return FALSE;
+
+ while (s < e && isBLANK(*s)) {
+ s++;
+ }
if isDIGIT(*s) {
min_start = s;
min_end = s;
}
+ while (s < e && isBLANK(*s)) {
+ s++;
+ }
+
if (*s == ',') {
has_comma = TRUE;
- s++;
+ s++;
+
+ while (s < e && isBLANK(*s)) {
+ s++;
+ }
+
if isDIGIT(*s) {
max_start = s;
do {
}
}
- if (s >= e || *s != '}' || ! min_start) {
+ while (s < e && isBLANK(*s)) {
+ s++;
+ }
+ /* Need at least one number */
+ if (s >= e || *s != '}' || (! min_start && ! max_end)) {
return FALSE;
}
if (result) {
-#define RBRACE 0
-#define MIN_S 1
-#define MIN_E 2
-#define MAX_S 3
-#define MAX_E 4
-
result[RBRACE] = s;
result[MIN_S] = min_start;
return TRUE;
}
+#endif
U32
S_get_quantifier_value(pTHX_ RExC_state_t *pRExC_state,
}
else if (*start == '0') { /* grok_atoUV() fails for only two reasons:
leading zeros or overflow */
- RExC_parse++;
+ RExC_parse_set((char * ) end);
/* Perhaps too generic a msg for what is only failure from having
* leading zeros, but this is how it's always behaved. */
/* Here, found a quantifier, but was too large; either it overflowed or was
* too big a legal number */
- RExC_parse++;
+ RExC_parse_set((char * ) end);
vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
NOT_REACHED; /*NOTREACHED*/
const char * const origparse = RExC_parse;
I32 min;
I32 max = REG_INFTY;
-#ifdef RE_TRACK_PATTERN_OFFSETS
- char *parse_start;
-#endif
+ I32 npar_before = RExC_npar-1;
/* Save the original in case we change the emitted regop to a FAIL. */
const regnode_offset orig_emit = RExC_emit;
RETURN_FAIL_ON_RESTART_OR_FLAGS(flags, flagp, TRYAGAIN);
FAIL2("panic: regatom returned failure, flags=%#" UVxf, (UV) flags);
}
-
-#ifdef RE_TRACK_PATTERN_OFFSETS
- parse_start = RExC_parse;
-#endif
+ I32 npar_after = RExC_npar-1;
op = *RExC_parse;
switch (op) {
const char * max_start = regcurly_return[MAX_S];
const char * max_end = regcurly_return[MAX_E];
- assert(min_start);
- assert(min_end > min_start);
- min = get_quantifier_value(pRExC_state, min_start, min_end);
+ if (min_start) {
+ min = get_quantifier_value(pRExC_state, min_start, min_end);
+ }
+ else {
+ min = 0;
+ }
if (max_start == max_end) { /* Was of the form {m,} */
max = REG_INFTY;
max = get_quantifier_value(pRExC_state, max_start, max_end);
}
- RExC_parse = (char *) regcurly_return[RBRACE];
+ RExC_parse_set((char *) regcurly_return[RBRACE]);
nextchar(pRExC_state);
if (max < min) { /* If can't match, warn and optimize to fail
reginsert(pRExC_state, OPFAIL, orig_emit, depth+1);
ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
NEXT_OFF(REGNODE_p(orig_emit)) =
- regarglen[OPFAIL] + NODE_STEP_REGNODE;
+ REGNODE_ARG_LEN(OPFAIL) + NODE_STEP_REGNODE;
return ret;
}
else if (min == max && *RExC_parse == '?') {
* Check and possibly adjust a zero width operand */
if (! (flags & (HASWIDTH|POSTPONED))) {
if (max > REG_INFTY/3) {
- if (origparse[0] == '\\' && origparse[1] == 'K') {
- vFAIL2utf8f(
- "%" UTF8f " is forbidden - matches null string"
- " many times",
- UTF8fARG(UTF, (RExC_parse >= origparse
- ? RExC_parse - origparse
- : 0),
- origparse));
- } else {
- ckWARN2reg(RExC_parse,
- "%" UTF8f " matches null string many times",
- UTF8fARG(UTF, (RExC_parse >= origparse
- ? RExC_parse - origparse
- : 0),
- origparse));
- }
+ ckWARN2reg(RExC_parse,
+ "%" UTF8f " matches null string many times",
+ UTF8fARG(UTF, (RExC_parse >= origparse
+ ? RExC_parse - origparse
+ : 0),
+ origparse));
}
/* There's no point in trying to match something 0 length more than
MARK_NAUGHTY_EXP(2, 2);
reginsert(pRExC_state, CURLY, ret, depth+1);
- Set_Node_Offset(REGNODE_p(ret), parse_start+1); /* MJD */
- Set_Node_Cur_Length(REGNODE_p(ret), parse_start);
}
else { /* not SIMPLE */
const regnode_offset w = reg_node(pRExC_state, WHILEM);
if (RExC_use_BRANCHJ) {
reginsert(pRExC_state, LONGJMP, ret, depth+1);
reginsert(pRExC_state, NOTHING, ret, depth+1);
- NEXT_OFF(REGNODE_p(ret)) = 3; /* Go over LONGJMP. */
+ REGNODE_STEP_OVER(ret,tregnode_NOTHING,tregnode_LONGJMP);
}
reginsert(pRExC_state, CURLYX, ret, depth+1);
- /* MJD hk */
- Set_Node_Offset(REGNODE_p(ret), parse_start+1);
- Set_Node_Length(REGNODE_p(ret),
- op == '{' ? (RExC_parse - parse_start) : 1);
-
if (RExC_use_BRANCHJ)
- NEXT_OFF(REGNODE_p(ret)) = 3; /* Go over NOTHING to
- LONGJMP. */
+ /* Go over NOTHING to LONGJMP. */
+ REGNODE_STEP_OVER(ret,tregnode_CURLYX,tregnode_NOTHING);
+
if (! REGTAIL(pRExC_state, ret, reg_node(pRExC_state,
NOTHING)))
{
/* Finish up the CURLY/CURLYX case */
FLAGS(REGNODE_p(ret)) = 0;
- ARG1_SET(REGNODE_p(ret), (U16)min);
- ARG2_SET(REGNODE_p(ret), (U16)max);
+ ARG1i_SET(REGNODE_p(ret), min);
+ ARG2i_SET(REGNODE_p(ret), max);
+
+ /* if we had a npar_after then we need to increment npar_before,
+ * we want to track the range of parens we need to reset each iteration
+ */
+ if (npar_after!=npar_before) {
+ ARG3a_SET(REGNODE_p(ret), (U16)npar_before+1);
+ ARG3b_SET(REGNODE_p(ret), (U16)npar_after);
+ } else {
+ ARG3a_SET(REGNODE_p(ret), 0);
+ ARG3b_SET(REGNODE_p(ret), 0);
+ }
done_main_op:
/* Forbid extra quantifiers */
if (isQUANTIFIER(RExC_parse, RExC_end)) {
- RExC_parse++;
+ RExC_parse_inc_by(1);
vFAIL("Nested quantifiers");
}
* reason is to make it harder to write patterns that take a long long time
* to halt, and because the use of this construct isn't necessary in
* matching Unicode property values */
- RExC_parse++;
+ RExC_parse_inc_by(1);
/* diag_listed_as: Use of %s is not allowed in Unicode property wildcard
subpatterns in regex; marked by <-- HERE in m/%s/
*/
* sequence. *node_p will be set to a generated node returned by this
* function calling S_reg().
*
- * The final possibility is that it is premature to be calling this function;
- * the parse needs to be restarted. This can happen when this changes from
- * /d to /u rules, or when the pattern needs to be upgraded to UTF-8. The
- * latter occurs only when the fifth possibility would otherwise be in
- * effect, and is because one of those code points requires the pattern to be
- * recompiled as UTF-8. The function returns FALSE, and sets the
+ * The sixth and final possibility is that it is premature to be calling this
+ * function; the parse needs to be restarted. This can happen when this
+ * changes from /d to /u rules, or when the pattern needs to be upgraded to
+ * UTF-8. The latter occurs only when the fifth possibility would otherwise
+ * be in effect, and is because one of those code points requires the pattern
+ * to be recompiled as UTF-8. The function returns FALSE, and sets the
* RESTART_PARSE and NEED_UTF8 flags in *flagp, as appropriate. When this
* happens, the caller needs to desist from continuing parsing, and return
* this information to its caller. This is not set for when there is only one
* are already native, so no translation is done. */
char * endbrace; /* points to '}' following the name */
+ char * e; /* points to final non-blank before endbrace */
char* p = RExC_parse; /* Temporary */
SV * substitute_parse = NULL;
}
/* The [^\n] meaning of \N ignores spaces and comments under the /x
- * modifier. The other meanings do not, so use a temporary until we find
- * out which we are being called with */
+ * modifier. The other meanings do not (except blanks adjacent to and
+ * within the braces), so use a temporary until we find out which we are
+ * being called with */
skip_to_be_ignored_text(pRExC_state, &p,
FALSE /* Don't force to /x */ );
* [^\n]. The latter is assumed when the {...} following the \N is a legal
* quantifier, or if there is no '{' at all */
if (*p != '{' || regcurly(p, RExC_end, NULL)) {
- RExC_parse = p;
+ RExC_parse_set(p);
if (cp_count) {
*cp_count = -1;
}
*node_p = reg_node(pRExC_state, REG_ANY);
*flagp |= HASWIDTH|SIMPLE;
MARK_NAUGHTY(1);
- Set_Node_Length(REGNODE_p(*(node_p)), 1); /* MJD */
return TRUE;
}
vFAIL("Missing braces on \\N{}");
}
- RExC_parse++; /* Skip past the '{' */
+ RExC_parse_inc_by(1); /* Skip past the '{' */
endbrace = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse);
if (! endbrace) { /* no trailing brace */
/* \N{_} is what toke.c returns to us to indicate a name that evaluates to
* nothing at all (not allowed under strict) */
if (endbrace - RExC_parse == 1 && *RExC_parse == '_') {
- RExC_parse = endbrace;
+ RExC_parse_set(endbrace);
if (strict) {
- RExC_parse++; /* Position after the "}" */
+ RExC_parse_inc_by(1); /* Position after the "}" */
vFAIL("Zero length \\N{}");
}
return TRUE;
}
- if (endbrace - RExC_parse < 2 || ! strBEGINs(RExC_parse, "U+")) {
+ while (isBLANK(*RExC_parse)) {
+ RExC_parse_inc_by(1);
+ }
+
+ e = endbrace;
+ while (RExC_parse < e && isBLANK(*(e-1))) {
+ e--;
+ }
+
+ if (e - RExC_parse < 2 || ! strBEGINs(RExC_parse, "U+")) {
/* Here, the name isn't of the form U+.... This can happen if the
* pattern is single-quoted, so didn't get evaluated in toke.c. Now
* is the time to find out what the name means */
- const STRLEN name_len = endbrace - RExC_parse;
+ const STRLEN name_len = e - RExC_parse;
SV * value_sv; /* What does this name evaluate to */
SV ** value_svp;
const U8 * value; /* string of name's value */
}
else { /* Otherwise we have to go out and get the name */
const char * error_msg = NULL;
- value_sv = get_and_check_backslash_N_name(RExC_parse, endbrace,
+ value_sv = get_and_check_backslash_N_name(RExC_parse, e,
UTF,
&error_msg);
if (error_msg) {
- RExC_parse = endbrace;
+ RExC_parse_set(endbrace);
vFAIL(error_msg);
}
/* Here, exactly one code point. If that isn't what is wanted,
* fail */
if (! code_point_p) {
- RExC_parse = p;
+ RExC_parse_set(p);
return FALSE;
}
/* Have parsed this entire single code point \N{...}. *cp_count
* has already been set to 1, so don't do it again. */
- RExC_parse = endbrace;
+ RExC_parse_set(endbrace);
nextchar(pRExC_state);
return TRUE;
} /* End of is a single code point */
* case). */
if (! node_p) {
if (! cp_count) {
- RExC_parse = p;
+ RExC_parse_set(p);
}
return FALSE;
}
* converted a name to the \N{U+...} form. This include changing a
* name that evaluates to multiple code points to \N{U+c1.c2.c3 ...} */
- RExC_parse += 2; /* Skip past the 'U+' */
+ RExC_parse_inc_by(2); /* Skip past the 'U+' */
/* Code points are separated by dots. The '}' terminates the whole
* thing. */
| PERL_SCAN_NOTIFY_ILLDIGIT
| PERL_SCAN_ALLOW_MEDIAL_UNDERSCORES
| PERL_SCAN_DISALLOW_PREFIX;
- STRLEN len = endbrace - RExC_parse;
+ STRLEN len = e - RExC_parse;
NV overflow_value;
char * start_digit = RExC_parse;
UV cp = grok_hex(RExC_parse, &len, &flags, &overflow_value);
if (len == 0) {
- RExC_parse++;
+ RExC_parse_inc_by(1);
bad_NU:
vFAIL("Invalid hexadecimal number in \\N{U+...}");
}
- RExC_parse += len;
+ RExC_parse_inc_by(len);
if (cp > MAX_LEGAL_CP) {
vFAIL(form_cp_too_large_msg(16, start_digit, len, 0));
}
- if (RExC_parse >= endbrace) { /* Got to the closing '}' */
+ if (RExC_parse >= e) { /* Got to the closing '}' */
if (count) {
goto do_concat;
}
/* Here, is a single code point; fail if doesn't want that */
if (! code_point_p) {
- RExC_parse = p;
+ RExC_parse_set(p);
return FALSE;
}
/* A single code point is easy to handle; just return it */
*code_point_p = UNI_TO_NATIVE(cp);
- RExC_parse = endbrace;
+ RExC_parse_set(endbrace);
nextchar(pRExC_state);
return TRUE;
}
* only if that character is a dot separating code points, like a
* multiple character sequence (of the form "\N{U+c1.c2. ... }".
* So the next character must be a dot (and the one after that
- * can't be the endbrace, or we'd have something like \N{U+100.} )
+ * can't be the ending brace, or we'd have something like
+ * \N{U+100.} )
* */
- if (*RExC_parse != '.' || RExC_parse + 1 >= endbrace) {
- RExC_parse += (RExC_orig_utf8) /* point to after 1st invalid */
- ? UTF8SKIP(RExC_parse)
- : 1;
- RExC_parse = MIN(endbrace, RExC_parse);/* Guard against
- malformed utf8 */
+ if (*RExC_parse != '.' || RExC_parse + 1 >= e) {
+ /*point to after 1st invalid */
+ RExC_parse_incf(RExC_orig_utf8);
+ /*Guard against malformed utf8*/
+ RExC_parse_set(MIN(e, RExC_parse));
goto bad_NU;
}
/* Move to after the dot (or ending brace the final time through.)
* */
- RExC_parse++;
+ RExC_parse_inc_by(1);
count++;
- } while (RExC_parse < endbrace);
+ } while (RExC_parse < e);
if (! node_p) { /* Doesn't want the node */
assert (cp_count);
* constructs. This can be called from within a substitute parse already.
* The error reporting mechanism doesn't work for 2 levels of this, but the
* code above has validated this new construct, so there should be no
- * errors generated by the below. And this isn' an exact copy, so the
+ * errors generated by the below. And this isn't an exact copy, so the
* mechanism to seamlessly deal with this won't work, so turn off warnings
* during it */
save_start = RExC_start;
orig_end = RExC_end;
- RExC_parse = RExC_start = SvPVX(substitute_parse);
+ RExC_start = SvPVX(substitute_parse);
+ RExC_parse_set(RExC_start);
RExC_end = RExC_parse + SvCUR(substitute_parse);
TURN_OFF_WARNINGS_IN_SUBSTITUTE_PARSE;
/* Restore the saved values */
RESTORE_WARNINGS;
RExC_start = save_start;
- RExC_parse = endbrace;
+ RExC_parse_set(endbrace);
RExC_end = orig_end;
SET_recode_x_to_native(0);
return op + EXACTF;
}
-STATIC bool
-S_new_regcurly(const char *s, const char *e)
-{
- /* This is a temporary function designed to match the most lenient form of
- * a {m,n} quantifier we ever envision, with either number omitted, and
- * spaces anywhere between/before/after them.
- *
- * If this function fails, then the string it matches is very unlikely to
- * ever be considered a valid quantifier, so we can allow the '{' that
- * begins it to be considered as a literal */
-
- bool has_min = FALSE;
- bool has_max = FALSE;
-
- PERL_ARGS_ASSERT_NEW_REGCURLY;
-
- if (s >= e || *s++ != '{')
- return FALSE;
-
- while (s < e && isSPACE(*s)) {
- s++;
- }
- while (s < e && isDIGIT(*s)) {
- has_min = TRUE;
- s++;
- }
- while (s < e && isSPACE(*s)) {
- s++;
- }
-
- if (*s == ',') {
- s++;
- while (s < e && isSPACE(*s)) {
- s++;
- }
- while (s < e && isDIGIT(*s)) {
- has_max = TRUE;
- s++;
- }
- while (s < e && isSPACE(*s)) {
- s++;
- }
- }
-
- return s < e && *s == '}' && (has_min || has_max);
-}
-
/* Parse backref decimal value, unless it's too big to sensibly be a backref,
* in which case return I32_MAX (rather than possibly 32-bit wrapping) */
A summary of the code structure is:
switch (first_byte) {
- cases for each special:
- handle this special;
- break;
- case '\\':
- switch (2nd byte) {
- cases for each unambiguous special:
- handle this special;
- break;
- cases for each ambigous special/literal:
- disambiguate;
- if (special) handle here
- else goto defchar;
- default: // unambiguously literal:
- goto defchar;
- }
- default: // is a literal char
- // FALL THROUGH
- defchar:
- create EXACTish node for literal;
- while (more input and node isn't full) {
- switch (input_byte) {
- cases for each special;
+ cases for each special:
+ handle this special;
+ break;
+ case '\\':
+ switch (2nd byte) {
+ cases for each unambiguous special:
+ handle this special;
+ break;
+ cases for each ambiguous special/literal:
+ disambiguate;
+ if (special) handle here
+ else goto defchar;
+ default: // unambiguously literal:
+ goto defchar;
+ }
+ default: // is a literal char
+ // FALL THROUGH
+ defchar:
+ create EXACTish node for literal;
+ while (more input and node isn't full) {
+ switch (input_byte) {
+ cases for each special;
make sure parse pointer is set so that the next call to
regatom will see this special first
goto loopdone; // EXACTish node terminated by prev. char
- default:
- append char to EXACTISH node;
- }
- get next input byte;
- }
+ default:
+ append char to EXACTISH node;
+ }
+ get next input byte;
+ }
loopdone:
}
return the generated node;
{
regnode_offset ret = 0;
I32 flags = 0;
- char *parse_start;
+ char *atom_parse_start;
U8 op;
int invert = 0;
PERL_ARGS_ASSERT_REGATOM;
tryagain:
- parse_start = RExC_parse;
+ atom_parse_start = RExC_parse;
assert(RExC_parse < RExC_end);
switch ((U8)*RExC_parse) {
case '^':
- RExC_seen_zerolen++;
- nextchar(pRExC_state);
- if (RExC_flags & RXf_PMf_MULTILINE)
- ret = reg_node(pRExC_state, MBOL);
- else
- ret = reg_node(pRExC_state, SBOL);
- Set_Node_Length(REGNODE_p(ret), 1); /* MJD */
- break;
+ RExC_seen_zerolen++;
+ nextchar(pRExC_state);
+ if (RExC_flags & RXf_PMf_MULTILINE)
+ ret = reg_node(pRExC_state, MBOL);
+ else
+ ret = reg_node(pRExC_state, SBOL);
+ break;
case '$':
- nextchar(pRExC_state);
- if (*RExC_parse)
- RExC_seen_zerolen++;
- if (RExC_flags & RXf_PMf_MULTILINE)
- ret = reg_node(pRExC_state, MEOL);
- else
- ret = reg_node(pRExC_state, SEOL);
- Set_Node_Length(REGNODE_p(ret), 1); /* MJD */
- break;
+ nextchar(pRExC_state);
+ if (*RExC_parse)
+ RExC_seen_zerolen++;
+ if (RExC_flags & RXf_PMf_MULTILINE)
+ ret = reg_node(pRExC_state, MEOL);
+ else
+ ret = reg_node(pRExC_state, SEOL);
+ break;
case '.':
- nextchar(pRExC_state);
- if (RExC_flags & RXf_PMf_SINGLELINE)
- ret = reg_node(pRExC_state, SANY);
- else
- ret = reg_node(pRExC_state, REG_ANY);
- *flagp |= HASWIDTH|SIMPLE;
- MARK_NAUGHTY(1);
- Set_Node_Length(REGNODE_p(ret), 1); /* MJD */
- break;
+ nextchar(pRExC_state);
+ if (RExC_flags & RXf_PMf_SINGLELINE)
+ ret = reg_node(pRExC_state, SANY);
+ else
+ ret = reg_node(pRExC_state, REG_ANY);
+ *flagp |= HASWIDTH|SIMPLE;
+ MARK_NAUGHTY(1);
+ break;
case '[':
{
- char * const oregcomp_parse = ++RExC_parse;
+ char * const cc_parse_start = ++RExC_parse;
ret = regclass(pRExC_state, flagp, depth+1,
FALSE, /* means parse the whole char class */
TRUE, /* allow multi-char folds */
FAIL2("panic: regclass returned failure to regatom, flags=%#" UVxf,
(UV) *flagp);
}
- if (*RExC_parse != ']') {
- RExC_parse = oregcomp_parse;
- vFAIL("Unmatched [");
- }
- nextchar(pRExC_state);
- Set_Node_Length(REGNODE_p(ret), RExC_parse - oregcomp_parse + 1); /* MJD */
- break;
+ if (*RExC_parse != ']') {
+ RExC_parse_set(cc_parse_start);
+ vFAIL("Unmatched [");
+ }
+ nextchar(pRExC_state);
+ break;
}
case '(':
- nextchar(pRExC_state);
+ nextchar(pRExC_state);
ret = reg(pRExC_state, 2, &flags, depth+1);
- if (ret == 0) {
- if (flags & TRYAGAIN) {
- if (RExC_parse >= RExC_end) {
- /* Make parent create an empty node if needed. */
- *flagp |= TRYAGAIN;
- return(0);
- }
- goto tryagain;
- }
+ if (ret == 0) {
+ if (flags & TRYAGAIN) {
+ if (RExC_parse >= RExC_end) {
+ /* Make parent create an empty node if needed. */
+ *flagp |= TRYAGAIN;
+ return(0);
+ }
+ goto tryagain;
+ }
RETURN_FAIL_ON_RESTART(flags, flagp);
FAIL2("panic: reg returned failure to regatom, flags=%#" UVxf,
(UV) flags);
- }
- *flagp |= flags&(HASWIDTH|SIMPLE|POSTPONED);
- break;
+ }
+ *flagp |= flags&(HASWIDTH|SIMPLE|POSTPONED);
+ break;
case '|':
case ')':
- if (flags & TRYAGAIN) {
- *flagp |= TRYAGAIN;
- return 0;
- }
- vFAIL("Internal urp");
- /* Supposed to be caught earlier. */
- break;
+ if (flags & TRYAGAIN) {
+ *flagp |= TRYAGAIN;
+ return 0;
+ }
+ vFAIL("Internal urp");
+ /* Supposed to be caught earlier. */
+ break;
case '?':
case '+':
case '*':
- RExC_parse++;
- vFAIL("Quantifier follows nothing");
- break;
+ RExC_parse_inc_by(1);
+ vFAIL("Quantifier follows nothing");
+ break;
case '\\':
- /* Special Escapes
-
- This switch handles escape sequences that resolve to some kind
- of special regop and not to literal text. Escape sequences that
- resolve to literal text are handled below in the switch marked
- "Literal Escapes".
-
- Every entry in this switch *must* have a corresponding entry
- in the literal escape switch. However, the opposite is not
- required, as the default for this switch is to jump to the
- literal text handling code.
- */
- RExC_parse++;
- switch ((U8)*RExC_parse) {
- /* Special Escapes */
- case 'A':
- RExC_seen_zerolen++;
+ /* Special Escapes
+
+ This switch handles escape sequences that resolve to some kind
+ of special regop and not to literal text. Escape sequences that
+ resolve to literal text are handled below in the switch marked
+ "Literal Escapes".
+
+ Every entry in this switch *must* have a corresponding entry
+ in the literal escape switch. However, the opposite is not
+ required, as the default for this switch is to jump to the
+ literal text handling code.
+ */
+ RExC_parse_inc_by(1);
+ switch ((U8)*RExC_parse) {
+ /* Special Escapes */
+ case 'A':
+ RExC_seen_zerolen++;
/* Under wildcards, this is changed to match \n; should be
* invisible to the user, as they have to compile under /m */
if (RExC_pm_flags & PMf_WILDCARD) {
* /\A/ from /^/ in split. */
FLAGS(REGNODE_p(ret)) = 1;
}
- goto finish_meta_pat;
- case 'G':
+ goto finish_meta_pat;
+ case 'G':
if (RExC_pm_flags & PMf_WILDCARD) {
- RExC_parse++;
+ RExC_parse_inc_by(1);
/* diag_listed_as: Use of %s is not allowed in Unicode property
wildcard subpatterns in regex; marked by <-- HERE in m/%s/
*/
vFAIL("Use of '\\G' is not allowed in Unicode property"
" wildcard subpatterns");
}
- ret = reg_node(pRExC_state, GPOS);
+ ret = reg_node(pRExC_state, GPOS);
RExC_seen |= REG_GPOS_SEEN;
- goto finish_meta_pat;
- case 'K':
+ goto finish_meta_pat;
+ case 'K':
if (!RExC_in_lookaround) {
RExC_seen_zerolen++;
ret = reg_node(pRExC_state, KEEPS);
++RExC_parse; /* advance past the 'K' */
vFAIL("\\K not permitted in lookahead/lookbehind");
}
- case 'Z':
+ case 'Z':
if (RExC_pm_flags & PMf_WILDCARD) {
/* See comment under \A above */
ret = reg_node(pRExC_state, MEOL);
else {
ret = reg_node(pRExC_state, SEOL);
}
- RExC_seen_zerolen++; /* Do not optimize RE away */
- goto finish_meta_pat;
- case 'z':
+ RExC_seen_zerolen++; /* Do not optimize RE away */
+ goto finish_meta_pat;
+ case 'z':
if (RExC_pm_flags & PMf_WILDCARD) {
/* See comment under \A above */
ret = reg_node(pRExC_state, MEOL);
else {
ret = reg_node(pRExC_state, EOS);
}
- RExC_seen_zerolen++; /* Do not optimize RE away */
- goto finish_meta_pat;
- case 'C':
- vFAIL("\\C no longer supported");
- case 'X':
- ret = reg_node(pRExC_state, CLUMP);
- *flagp |= HASWIDTH;
- goto finish_meta_pat;
+ RExC_seen_zerolen++; /* Do not optimize RE away */
+ goto finish_meta_pat;
+ case 'C':
+ vFAIL("\\C no longer supported");
+ case 'X':
+ ret = reg_node(pRExC_state, CLUMP);
+ *flagp |= HASWIDTH;
+ goto finish_meta_pat;
- case 'B':
+ case 'B':
invert = 1;
/* FALLTHROUGH */
- case 'b':
+ case 'b':
{
U8 flags = 0;
- regex_charset charset = get_regex_charset(RExC_flags);
+ regex_charset charset = get_regex_charset(RExC_flags);
- RExC_seen_zerolen++;
+ RExC_seen_zerolen++;
RExC_seen |= REG_LOOKBEHIND_SEEN;
- op = BOUND + charset;
+ op = BOUND + charset;
- if (RExC_parse >= RExC_end || *(RExC_parse + 1) != '{') {
+ if (RExC_parse >= RExC_end || *(RExC_parse + 1) != '{') {
flags = TRADITIONAL_BOUND;
if (op > BOUNDA) { /* /aa is same as /a */
op = BOUNDA;
else {
STRLEN length;
char name = *RExC_parse;
- char * endbrace = NULL;
- RExC_parse += 2;
- endbrace = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse);
+ char * endbrace = (char *) memchr(RExC_parse, '}',
+ RExC_end - RExC_parse);
+ char * e = endbrace;
+
+ RExC_parse_inc_by(2);
if (! endbrace) {
vFAIL2("Missing right brace on \\%c{}", name);
}
- /* XXX Need to decide whether to take spaces or not. Should be
- * consistent with \p{}, but that currently is SPACE, which
- * means vertical too, which seems wrong
- * while (isBLANK(*RExC_parse)) {
- RExC_parse++;
- }*/
- if (endbrace == RExC_parse) {
- RExC_parse++; /* After the '}' */
+
+ while (isBLANK(*RExC_parse)) {
+ RExC_parse_inc_by(1);
+ }
+
+ while (RExC_parse < e && isBLANK(*(e - 1))) {
+ e--;
+ }
+
+ if (e == RExC_parse) {
+ RExC_parse_set(endbrace + 1); /* After the '}' */
vFAIL2("Empty \\%c{}", name);
}
- length = endbrace - RExC_parse;
- /*while (isBLANK(*(RExC_parse + length - 1))) {
- length--;
- }*/
+
+ length = e - RExC_parse;
+
switch (*RExC_parse) {
case 'g':
if ( length != 1
break;
default:
bad_bound_type:
- RExC_parse = endbrace;
- vFAIL2utf8f(
+ RExC_parse_set(e);
+ vFAIL2utf8f(
"'%" UTF8f "' is an unknown bound type",
- UTF8fARG(UTF, length, endbrace - length));
+ UTF8fARG(UTF, length, e - length));
NOT_REACHED; /*NOTREACHED*/
}
- RExC_parse = endbrace;
+ RExC_parse_set(endbrace);
REQUIRE_UNI_RULES(flagp, 0);
if (op == BOUND) {
? ASCII_RESTRICT_PAT_MODS
: ASCII_MORE_RESTRICT_PAT_MODS);
}
- }
+ }
if (op == BOUND) {
RExC_seen_d_op = TRUE;
op += NBOUND - BOUND;
}
- ret = reg_node(pRExC_state, op);
+ ret = reg_node(pRExC_state, op);
FLAGS(REGNODE_p(ret)) = flags;
- goto finish_meta_pat;
+ goto finish_meta_pat;
}
- case 'R':
- ret = reg_node(pRExC_state, LNBREAK);
- *flagp |= HASWIDTH|SIMPLE;
- goto finish_meta_pat;
-
- case 'd':
- case 'D':
- case 'h':
- case 'H':
- case 'p':
- case 'P':
- case 's':
- case 'S':
- case 'v':
- case 'V':
- case 'w':
- case 'W':
+ case 'R':
+ ret = reg_node(pRExC_state, LNBREAK);
+ *flagp |= HASWIDTH|SIMPLE;
+ goto finish_meta_pat;
+
+ case 'd':
+ case 'D':
+ case 'h':
+ case 'H':
+ case 'p':
+ case 'P':
+ case 's':
+ case 'S':
+ case 'v':
+ case 'V':
+ case 'w':
+ case 'W':
/* These all have the same meaning inside [brackets], and it knows
* how to do the best optimizations for them. So, pretend we found
* these within brackets, and let it do the work */
/* The escapes above that don't take a parameter can't be
* followed by a '{'. But 'pX', 'p{foo}' and
* correspondingly 'P' can be */
- if ( RExC_parse - parse_start == 1
+ if ( RExC_parse - atom_parse_start == 1
&& UCHARAT(RExC_parse + 1) == '{'
- && UNLIKELY(! new_regcurly(RExC_parse + 1, RExC_end)))
+ && UNLIKELY(! regcurly(RExC_parse + 1, RExC_end, NULL)))
{
- RExC_parse += 2;
+ RExC_parse_inc_by(2);
vFAIL("Unescaped left brace in regex is illegal here");
}
- Set_Node_Offset(REGNODE_p(ret), parse_start);
- Set_Node_Length(REGNODE_p(ret), RExC_parse - parse_start + 1); /* MJD */
nextchar(pRExC_state);
- break;
+ break;
case 'N':
/* Handle \N, \N{} and \N{NAMED SEQUENCE} (the latter meaning the
* \N{...} evaluates to a sequence of more than one code points).
RETURN_FAIL_ON_RESTART_FLAGP(flagp);
/* Here, evaluates to a single code point. Go get that */
- RExC_parse = parse_start;
+ RExC_parse_set(atom_parse_start);
goto defchar;
- case 'k': /* Handle \k<NAME> and \k'NAME' */
- parse_named_seq:
+ case 'k': /* Handle \k<NAME> and \k'NAME' and \k{NAME} */
+ parse_named_seq: /* Also handle non-numeric \g{...} */
{
char ch;
if ( RExC_parse >= RExC_end - 1
&& ch != '\''
&& ch != '{'))
{
- RExC_parse++;
- /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
- vFAIL2("Sequence %.2s... not terminated", parse_start);
- } else {
- RExC_parse += 2;
+ RExC_parse_inc_by(1);
+ /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
+ vFAIL2("Sequence %.2s... not terminated", atom_parse_start);
+ } else {
+ RExC_parse_inc_by(2);
+ if (ch == '{') {
+ while (isBLANK(*RExC_parse)) {
+ RExC_parse_inc_by(1);
+ }
+ }
ret = handle_named_backref(pRExC_state,
flagp,
- parse_start,
+ atom_parse_start,
(ch == '<')
? '>'
: (ch == '{')
: '\'');
}
break;
- }
- case 'g':
- case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9':
- {
- I32 num;
- bool hasbrace = 0;
-
- if (*RExC_parse == 'g') {
+ }
+ case 'g':
+ case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ {
+ I32 num;
+ char * endbrace = NULL;
+ char * s = RExC_parse;
+ char * e = RExC_end;
+
+ if (*s == 'g') {
bool isrel = 0;
- RExC_parse++;
- if (*RExC_parse == '{') {
- RExC_parse++;
- hasbrace = 1;
- }
- if (*RExC_parse == '-') {
- RExC_parse++;
- isrel = 1;
- }
- if (hasbrace && !isDIGIT(*RExC_parse)) {
- if (isrel) RExC_parse--;
- RExC_parse -= 2;
- goto parse_named_seq;
+ s++;
+ if (*s == '{') {
+ endbrace = (char *) memchr(s, '}', RExC_end - s);
+ if (! endbrace ) {
+
+ /* Missing '}'. Position after the number to give
+ * a better indication to the user of where the
+ * problem is. */
+ s++;
+ if (*s == '-') {
+ s++;
+ }
+
+ /* If it looks to be a name and not a number, go
+ * handle it there */
+ if (! isDIGIT(*s)) {
+ goto parse_named_seq;
+ }
+
+ do {
+ s++;
+ } while isDIGIT(*s);
+
+ RExC_parse_set(s);
+ vFAIL("Unterminated \\g{...} pattern");
+ }
+
+ s++; /* Past the '{' */
+
+ while (isBLANK(*s)) {
+ s++;
+ }
+
+ /* Ignore trailing blanks */
+ e = endbrace;
+ while (s < e && isBLANK(*(e - 1))) {
+ e--;
+ }
}
- if (RExC_parse >= RExC_end) {
- goto unterminated_g;
+ /* Here, have isolated the meat of the construct from any
+ * surrounding braces */
+
+ if (*s == '-') {
+ isrel = 1;
+ s++;
+ }
+
+ if (endbrace && !isDIGIT(*s)) {
+ goto parse_named_seq;
}
+
+ RExC_parse_set(s);
num = S_backref_value(RExC_parse, RExC_end);
if (num == 0)
vFAIL("Reference to invalid group 0");
else if (num == I32_MAX) {
if (isDIGIT(*RExC_parse))
- vFAIL("Reference to nonexistent group");
+ vFAIL("Reference to nonexistent group");
else
- unterminated_g:
vFAIL("Unterminated \\g... pattern");
}
if (num < 1)
vFAIL("Reference to nonexistent or unclosed group");
}
+ else
+ if (num < RExC_logical_npar) {
+ num = RExC_logical_to_parno[num];
+ }
+ else
+ if (ALL_PARENS_COUNTED) {
+ if (num < RExC_logical_total_parens)
+ num = RExC_logical_to_parno[num];
+ else {
+ num = -1;
+ }
+ }
+ else{
+ REQUIRE_PARENS_PASS;
+ }
}
else {
num = S_backref_value(RExC_parse, RExC_end);
/* Note we do NOT check if num == I32_MAX here, as that is
* handled by the RExC_npar check */
- if (
- /* any numeric escape < 10 is always a backref */
- num > 9
- /* any numeric escape < RExC_npar is a backref */
- && num >= RExC_npar
- /* cannot be an octal escape if it starts with [89] */
+ if ( /* any numeric escape < 10 is always a backref */
+ num > 9
+ /* any numeric escape < RExC_npar is a backref */
+ && num >= RExC_logical_npar
+ /* cannot be an octal escape if it starts with [89]
+ * */
&& ! inRANGE(*RExC_parse, '8', '9')
) {
/* Probably not meant to be a backref, instead likely
* to be an octal character escape, e.g. \35 or \777.
* The above logic should make it obvious why using
* octal escapes in patterns is problematic. - Yves */
- RExC_parse = parse_start;
+ RExC_parse_set(atom_parse_start);
goto defchar;
}
+ if (num < RExC_logical_npar) {
+ num = RExC_logical_to_parno[num];
+ }
+ else
+ if (ALL_PARENS_COUNTED) {
+ if (num < RExC_logical_total_parens) {
+ num = RExC_logical_to_parno[num];
+ } else {
+ num = -1;
+ }
+ } else {
+ REQUIRE_PARENS_PASS;
+ }
}
/* At this point RExC_parse points at a numeric escape like
- * \12 or \88 or something similar, which we should NOT treat
- * as an octal escape. It may or may not be a valid backref
- * escape. For instance \88888888 is unlikely to be a valid
- * backref. */
- while (isDIGIT(*RExC_parse))
- RExC_parse++;
- if (hasbrace) {
- if (*RExC_parse != '}')
- vFAIL("Unterminated \\g{...} pattern");
- RExC_parse++;
+ * \12 or \88 or the digits in \g{34} or \g34 or something
+ * similar, which we should NOT treat as an octal escape. It
+ * may or may not be a valid backref escape. For instance
+ * \88888888 is unlikely to be a valid backref.
+ *
+ * We've already figured out what value the digits represent.
+ * Now, move the parse to beyond them. */
+ if (endbrace) {
+ RExC_parse_set(endbrace + 1);
}
- if (num >= (I32)RExC_npar) {
+ else while (isDIGIT(*RExC_parse)) {
+ RExC_parse_inc_by(1);
+ }
+ if (num < 0)
+ vFAIL("Reference to nonexistent group");
+ if (num >= (I32)RExC_npar) {
/* It might be a forward reference; we can't fail until we
* know, by completing the parse to get all the groups, and
* then reparsing */
}
}
RExC_sawback = 1;
- ret = reganode(pRExC_state,
+ ret = reg2node(pRExC_state,
((! FOLD)
? REF
: (ASCII_FOLD_RESTRICTED)
: (LOC)
? REFFL
: REFF),
- num);
+ num, RExC_nestroot);
+ if (RExC_nestroot && num >= RExC_nestroot)
+ FLAGS(REGNODE_p(ret)) = VOLATILE_REF;
if (OP(REGNODE_p(ret)) == REFF) {
RExC_seen_d_op = TRUE;
}
*flagp |= HASWIDTH;
- /* override incorrect value set in reganode MJD */
- Set_Node_Offset(REGNODE_p(ret), parse_start);
- Set_Node_Cur_Length(REGNODE_p(ret), parse_start-1);
skip_to_be_ignored_text(pRExC_state, &RExC_parse,
FALSE /* Don't force to /x */ );
- }
- break;
- case '\0':
- if (RExC_parse >= RExC_end)
- FAIL("Trailing \\");
- /* FALLTHROUGH */
- default:
- /* Do not generate "unrecognized" warnings here, we fall
- back into the quick-grab loop below */
- RExC_parse = parse_start;
- goto defchar;
- } /* end of switch on a \foo sequence */
- break;
+ }
+ break;
+ case '\0':
+ if (RExC_parse >= RExC_end)
+ FAIL("Trailing \\");
+ /* FALLTHROUGH */
+ default:
+ /* Do not generate "unrecognized" warnings here, we fall
+ back into the quick-grab loop below */
+ RExC_parse_set(atom_parse_start);
+ goto defchar;
+ } /* end of switch on a \foo sequence */
+ break;
case '#':
/* '#' comments should have been spaced over before this function was
* called */
assert((RExC_flags & RXf_PMf_EXTENDED) == 0);
- /*
+ /*
if (RExC_flags & RXf_PMf_EXTENDED) {
- RExC_parse = reg_skipcomment( pRExC_state, RExC_parse );
- if (RExC_parse < RExC_end)
- goto tryagain;
- }
+ RExC_parse_set( reg_skipcomment( pRExC_state, RExC_parse ) );
+ if (RExC_parse < RExC_end)
+ goto tryagain;
+ }
*/
- /* FALLTHROUGH */
+ /* FALLTHROUGH */
default:
- defchar: {
+ defchar: {
/* Here, we have determined that the next thing is probably a
* literal character. RExC_parse points to the first byte of its
* definition. (It still may be an escape sequence that evaluates
* to a single character) */
- STRLEN len = 0;
- UV ender = 0;
- char *p;
- char *s, *old_s = NULL, *old_old_s = NULL;
- char *s0;
+ STRLEN len = 0;
+ UV ender = 0;
+ char *p;
+ char *s, *old_s = NULL, *old_old_s = NULL;
+ char *s0;
U32 max_string_len = 255;
/* We may have to reparse the node, artificially stopping filling
/* Allocate an EXACT node. The node_type may change below to
* another EXACTish node, but since the size of the node doesn't
* change, it works */
- ret = regnode_guts(pRExC_state, node_type, current_string_nodes,
- "exact");
+ ret = REGNODE_GUTS(pRExC_state, node_type, current_string_nodes);
FILL_NODE(ret, node_type);
- RExC_emit++;
+ RExC_emit += NODE_STEP_REGNODE;
- s = STRING(REGNODE_p(ret));
+ s = STRING(REGNODE_p(ret));
s0 = s;
- reparse:
+ reparse:
p = RExC_parse;
len = 0;
* The exceptions override this */
Size_t added_len = 1;
- oldp = p;
+ oldp = p;
old_old_s = old_s;
old_s = s;
assert( (RExC_flags & RXf_PMf_EXTENDED) == 0
|| ! is_PATWS_safe((p), RExC_end, UTF));
- switch ((U8)*p) {
+ switch ((U8)*p) {
const char* message;
U32 packed_warn;
U8 grok_c_char;
- case '^':
- case '$':
- case '.':
- case '[':
- case '(':
- case ')':
- case '|':
- goto loopdone;
- case '\\':
- /* Literal Escapes Switch
-
- This switch is meant to handle escape sequences that
- resolve to a literal character.
-
- Every escape sequence that represents something
- else, like an assertion or a char class, is handled
- in the switch marked 'Special Escapes' above in this
- routine, but also has an entry here as anything that
- isn't explicitly mentioned here will be treated as
- an unescaped equivalent literal.
- */
-
- switch ((U8)*++p) {
-
- /* These are all the special escapes. */
- case 'A': /* Start assertion */
- case 'b': case 'B': /* Word-boundary assertion*/
- case 'C': /* Single char !DANGEROUS! */
- case 'd': case 'D': /* digit class */
- case 'g': case 'G': /* generic-backref, pos assertion */
- case 'h': case 'H': /* HORIZWS */
- case 'k': case 'K': /* named backref, keep marker */
- case 'p': case 'P': /* Unicode property */
- case 'R': /* LNBREAK */
- case 's': case 'S': /* space class */
- case 'v': case 'V': /* VERTWS */
- case 'w': case 'W': /* word class */
+ case '^':
+ case '$':
+ case '.':
+ case '[':
+ case '(':
+ case ')':
+ case '|':
+ goto loopdone;
+ case '\\':
+ /* Literal Escapes Switch
+
+ This switch is meant to handle escape sequences that
+ resolve to a literal character.
+
+ Every escape sequence that represents something
+ else, like an assertion or a char class, is handled
+ in the switch marked 'Special Escapes' above in this
+ routine, but also has an entry here as anything that
+ isn't explicitly mentioned here will be treated as
+ an unescaped equivalent literal.
+ */
+
+ switch ((U8)*++p) {
+
+ /* These are all the special escapes. */
+ case 'A': /* Start assertion */
+ case 'b': case 'B': /* Word-boundary assertion*/
+ case 'C': /* Single char !DANGEROUS! */
+ case 'd': case 'D': /* digit class */
+ case 'g': case 'G': /* generic-backref, pos assertion */
+ case 'h': case 'H': /* HORIZWS */
+ case 'k': case 'K': /* named backref, keep marker */
+ case 'p': case 'P': /* Unicode property */
+ case 'R': /* LNBREAK */
+ case 's': case 'S': /* space class */
+ case 'v': case 'V': /* VERTWS */
+ case 'w': case 'W': /* word class */
case 'X': /* eXtended Unicode "combining
character sequence" */
- case 'z': case 'Z': /* End of line/string assertion */
- --p;
- goto loopdone;
-
- /* Anything after here is an escape that resolves to a
- literal. (Except digits, which may or may not)
- */
- case 'n':
- ender = '\n';
- p++;
- break;
- case 'N': /* Handle a single-code point named character. */
- RExC_parse = p + 1;
+ case 'z': case 'Z': /* End of line/string assertion */
+ --p;
+ goto loopdone;
+
+ /* Anything after here is an escape that resolves to a
+ literal. (Except digits, which may or may not)
+ */
+ case 'n':
+ ender = '\n';
+ p++;
+ break;
+ case 'N': /* Handle a single-code point named character. */
+ RExC_parse_set( p + 1 );
if (! grok_bslash_N(pRExC_state,
NULL, /* Fail if evaluates to
anything other than a
/* Here, it wasn't a single code point. Go close
* up this EXACTish node. The switch() prior to
* this switch handles the other cases */
- RExC_parse = p = oldp;
+ p = oldp;
+ RExC_parse_set(p);
goto loopdone;
}
p = RExC_parse;
- RExC_parse = parse_start;
+ RExC_parse_set(atom_parse_start);
/* The \N{} means the pattern, if previously /d,
* becomes /u. That means it can't be an EXACTF node,
}
break;
- case 'r':
- ender = '\r';
- p++;
- break;
- case 't':
- ender = '\t';
- p++;
- break;
- case 'f':
- ender = '\f';
- p++;
- break;
- case 'e':
- ender = ESC_NATIVE;
- p++;
- break;
- case 'a':
- ender = '\a';
- p++;
- break;
- case 'o':
+ case 'r':
+ ender = '\r';
+ p++;
+ break;
+ case 't':
+ ender = '\t';
+ p++;
+ break;
+ case 'f':
+ ender = '\f';
+ p++;
+ break;
+ case 'e':
+ ender = ESC_NATIVE;
+ p++;
+ break;
+ case 'a':
+ ender = '\a';
+ p++;
+ break;
+ case 'o':
if (! grok_bslash_o(&p,
RExC_end,
&ender,
FALSE, /* No illegal cp's */
UTF))
{
- RExC_parse = p; /* going to die anyway; point to
+ RExC_parse_set(p); /* going to die anyway; point to
exact spot of failure */
vFAIL(message);
}
warn_non_literal_string(p, packed_warn, message);
}
break;
- case 'x':
+ case 'x':
if (! grok_bslash_x(&p,
RExC_end,
&ender,
FALSE, /* No illegal cp's */
UTF))
{
- RExC_parse = p; /* going to die anyway; point
+ RExC_parse_set(p); /* going to die anyway; point
to exact spot of failure */
vFAIL(message);
}
}
#endif
break;
- case 'c':
+ case 'c':
p++;
if (! grok_bslash_c(*p, &grok_c_char,
&message, &packed_warn))
{
/* going to die anyway; point to exact spot of
* failure */
- RExC_parse = p + ((UTF)
+ char *new_p= p + ((UTF)
? UTF8_SAFE_SKIP(p, RExC_end)
: 1);
+ RExC_parse_set(new_p);
vFAIL(message);
}
warn_non_literal_string(p, packed_warn, message);
}
- break;
+ break;
case '8': case '9': /* must be a backreference */
--p;
/* we have an escape like \8 which cannot be an octal escape
* escape which may or may not be a legitimate backref. */
goto loopdone;
case '1': case '2': case '3':case '4':
- case '5': case '6': case '7':
+ case '5': case '6': case '7':
+
/* When we parse backslash escapes there is ambiguity
* between backreferences and octal escapes. Any escape
* from \1 - \9 is a backreference, any multi-digit
if ( !isDIGIT(p[1]) || S_backref_value(p, RExC_end) < RExC_npar)
{ /* Not to be treated as an octal constant, go
find backref */
- --p;
+ p = oldp;
goto loopdone;
}
/* FALLTHROUGH */
case '0':
- {
- I32 flags = PERL_SCAN_SILENT_ILLDIGIT
+ {
+ I32 flags = PERL_SCAN_SILENT_ILLDIGIT
| PERL_SCAN_NOTIFY_ILLDIGIT;
- STRLEN numlen = 3;
- ender = grok_oct(p, &numlen, &flags, NULL);
- p += numlen;
+ STRLEN numlen = 3;
+ ender = grok_oct(p, &numlen, &flags, NULL);
+ p += numlen;
if ( (flags & PERL_SCAN_NOTIFY_ILLDIGIT)
&& isDIGIT(*p) /* like \08, \178 */
&& ckWARN(WARN_REGEXP))
{
- reg_warn_non_literal_string(
+ reg_warn_non_literal_string(
p + 1,
form_alien_digit_msg(8, numlen, p,
RExC_end, UTF, FALSE));
}
- }
- break;
- case '\0':
- if (p >= RExC_end)
- FAIL("Trailing \\");
- /* FALLTHROUGH */
- default:
- if (isALPHANUMERIC(*p)) {
+ }
+ break;
+ case '\0':
+ if (p >= RExC_end)
+ FAIL("Trailing \\");
+ /* FALLTHROUGH */
+ default:
+ if (isALPHANUMERIC(*p)) {
/* An alpha followed by '{' is going to fail next
* iteration, so don't output this warning in that
* case */
ckWARN2reg(p + 1, "Unrecognized escape \\%.1s"
" passed through", p);
}
- }
- goto normal_default;
- } /* End of switch on '\' */
- break;
- case '{':
+ }
+ goto normal_default;
+ } /* End of switch on '\' */
+ break;
+ case '{':
/* Trying to gain new uses for '{' without breaking too
* much existing code is hard. The solution currently
* adopted is:
* misspelled the quantifier. Without this warning,
* the quantifier would silently be taken as a literal
* string of characters instead of a meta construct */
- if (len || (p > RExC_start && isALPHA_A(*(p - 1)))) {
+ if (len || (p > RExC_start && isALPHA_A(*(p - 1)))) {
if ( RExC_strict
- || ( p > parse_start + 1
+ || ( p > atom_parse_start + 1
&& isALPHA_A(*(p - 1))
- && *(p - 2) == '\\')
- || new_regcurly(p, RExC_end))
+ && *(p - 2) == '\\'))
{
- RExC_parse = p + 1;
+ RExC_parse_set(p + 1);
vFAIL("Unescaped left brace in regex is "
"illegal here");
}
ckWARNreg(p + 1, "Unescaped left brace in regex is"
" passed through");
- }
- goto normal_default;
+ }
+ goto normal_default;
case '}':
case ']':
if (p > RExC_parse && RExC_strict) {
ckWARN2reg(p + 1, "Unescaped literal '%c'", *p);
}
- /*FALLTHROUGH*/
- default: /* A literal character */
- normal_default:
- if (! UTF8_IS_INVARIANT(*p) && UTF) {
- STRLEN numlen;
- ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
- &numlen, UTF8_ALLOW_DEFAULT);
- p += numlen;
- }
- else
- ender = (U8) *p++;
- break;
- } /* End of switch on the literal */
-
- /* Here, have looked at the literal character, and <ender>
+ /*FALLTHROUGH*/
+ default: /* A literal character */
+ normal_default:
+ if (! UTF8_IS_INVARIANT(*p) && UTF) {
+ STRLEN numlen;
+ ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
+ &numlen, UTF8_ALLOW_DEFAULT);
+ p += numlen;
+ }
+ else
+ ender = (U8) *p++;
+ break;
+ } /* End of switch on the literal */
+
+ /* Here, have looked at the literal character, and <ender>
* contains its ordinal; <p> points to the character after it.
* */
* requires UTF-8 to represent. */
: (char) toLOWER_L1(ender);
}
- } /* End of adding current character to the node */
+ } /* End of adding current character to the node */
done_with_this_char:
len += added_len;
- if (next_is_quantifier) {
+ if (next_is_quantifier) {
/* Here, the next input is a quantifier, and to get here,
* the current character is the only one in the node. */
goto loopdone;
- }
+ }
- } /* End of loop through literal characters */
+ } /* End of loop through literal characters */
/* Here we have either exhausted the input or run out of room in
* the node. If the former, we are done. (If we encountered a
* eventually we'll have to artificially chunk the pattern into
* multiple nodes. */
if (! LOC && (node_type == EXACT || node_type == LEXACT)) {
- Size_t overhead = 1 + regarglen[OP(REGNODE_p(ret))];
+ Size_t overhead = 1 + REGNODE_ARG_LEN(OP(REGNODE_p(ret)));
Size_t overhead_expansion = 0;
char temp[256];
Size_t max_nodes_for_string;
* to save the string in the EXACT case before growing, and
* then copy it afterwards to its new location */
if (node_type == EXACT) {
- overhead_expansion = regarglen[LEXACT] - regarglen[EXACT];
+ overhead_expansion = REGNODE_ARG_LEN(LEXACT) - REGNODE_ARG_LEN(EXACT);
RExC_emit += overhead_expansion;
Copy(s0, temp, len, char);
}
Safefree(locfold_buf);
Safefree(loc_correspondence);
}
- } /* End of verifying node ends with an appropriate char */
+ } /* End of verifying node ends with an appropriate char */
/* We need to start the next node at the character that didn't fit
* in this one */
*flagp |= HASWIDTH | maybe_SIMPLE;
}
- Set_Node_Length(REGNODE_p(ret), p - parse_start - 1);
- RExC_parse = p;
+ RExC_parse_set(p);
- {
- /* len is STRLEN which is unsigned, need to copy to signed */
- IV iv = len;
- if (iv < 0)
- vFAIL("Internal disaster");
- }
+ {
+ /* len is STRLEN which is unsigned, need to copy to signed */
+ IV iv = len;
+ if (iv < 0)
+ vFAIL("Internal disaster");
+ }
- } /* End of label 'defchar:' */
- break;
+ } /* End of label 'defchar:' */
+ break;
} /* End of giant switch on input character */
/* Position parse to next real character */
if ( *RExC_parse == '{'
&& OP(REGNODE_p(ret)) != SBOL && ! regcurly(RExC_parse, RExC_end, NULL))
{
- if (RExC_strict || new_regcurly(RExC_parse, RExC_end)) {
- RExC_parse++;
+ if (RExC_strict) {
+ RExC_parse_inc_by(1);
vFAIL("Unescaped left brace in regex is illegal here");
}
ckWARNreg(RExC_parse + 1, "Unescaped left brace in regex is"
}
-STATIC void
-S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr)
+#ifdef PERL_RE_BUILD_AUX
+void
+Perl_populate_anyof_bitmap_from_invlist(pTHX_ regnode *node, SV** invlist_ptr)
{
/* Uses the inversion list '*invlist_ptr' to populate the ANYOF 'node'. It
* sets up the bitmap and any flags, removing those code points from the
* inversion list, setting it to NULL should it become completely empty */
- PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST;
- assert(PL_regkind[OP(node)] == ANYOF);
+ PERL_ARGS_ASSERT_POPULATE_ANYOF_BITMAP_FROM_INVLIST;
/* There is no bitmap for this node type */
- if (inRANGE(OP(node), ANYOFH, ANYOFRb)) {
+ if (REGNODE_TYPE(OP(node)) != ANYOF) {
return;
}
ANYOF_BITMAP_ZERO(node);
if (*invlist_ptr) {
- /* This gets set if we actually need to modify things */
- bool change_invlist = FALSE;
+ /* This gets set if we actually need to modify things */
+ bool change_invlist = FALSE;
- UV start, end;
+ UV start, end;
- /* Start looking through *invlist_ptr */
- invlist_iterinit(*invlist_ptr);
- while (invlist_iternext(*invlist_ptr, &start, &end)) {
- UV high;
- int i;
+ /* Start looking through *invlist_ptr */
+ invlist_iterinit(*invlist_ptr);
+ while (invlist_iternext(*invlist_ptr, &start, &end)) {
+ UV high;
+ int i;
- if (end == UV_MAX && start <= NUM_ANYOF_CODE_POINTS) {
- ANYOF_FLAGS(node) |= ANYOF_MATCHES_ALL_ABOVE_BITMAP;
+ /* Quit if are above what we should change */
+ if (start >= NUM_ANYOF_CODE_POINTS) {
+ break;
}
- /* Quit if are above what we should change */
- if (start >= NUM_ANYOF_CODE_POINTS) {
- break;
- }
-
- change_invlist = TRUE;
+ change_invlist = TRUE;
- /* Set all the bits in the range, up to the max that we are doing */
- high = (end < NUM_ANYOF_CODE_POINTS - 1)
+ /* Set all the bits in the range, up to the max that we are doing */
+ high = (end < NUM_ANYOF_CODE_POINTS - 1)
? end
: NUM_ANYOF_CODE_POINTS - 1;
- for (i = start; i <= (int) high; i++) {
+ for (i = start; i <= (int) high; i++) {
ANYOF_BITMAP_SET(node, i);
- }
- }
- invlist_iterfinish(*invlist_ptr);
+ }
+ }
+ invlist_iterfinish(*invlist_ptr);
/* Done with loop; remove any code points that are in the bitmap from
- * *invlist_ptr; similarly for code points above the bitmap if we have
- * a flag to match all of them anyways */
- if (change_invlist) {
- _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr);
- }
- if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
- _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr);
- }
-
- /* If have completely emptied it, remove it completely */
- if (_invlist_len(*invlist_ptr) == 0) {
- SvREFCNT_dec_NN(*invlist_ptr);
- *invlist_ptr = NULL;
- }
+ * *invlist_ptr */
+ if (change_invlist) {
+ _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr);
+ }
+
+ /* If have completely emptied it, remove it completely */
+ if (_invlist_len(*invlist_ptr) == 0) {
+ SvREFCNT_dec_NN(*invlist_ptr);
+ *invlist_ptr = NULL;
+ }
}
}
+#endif /* PERL_RE_BUILD_AUX */
/* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
Character classes ([:foo:]) can also be negated ([:^foo:]).
if (posix_warnings) { \
if (! RExC_warn_text ) RExC_warn_text = \
(AV *) sv_2mortal((SV *) newAV()); \
- av_push(RExC_warn_text, Perl_newSVpvf(aTHX_ \
+ av_push_simple(RExC_warn_text, Perl_newSVpvf(aTHX_ \
WARNING_PREFIX \
text \
REPORT_LOCATION, \
/* These two constructs are not handled by perl, and if we find a
* syntactically valid one, we croak. khw, who wrote this code, finds
* this explanation of them very unclear:
- * http://pubs.opengroup.org/onlinepubs/009696899/basedefs/xbd_chap09.html
+ * https://pubs.opengroup.org/onlinepubs/009696899/basedefs/xbd_chap09.html
* And searching the rest of the internet wasn't very helpful either.
* It looks like just about any byte can be in these constructs,
* depending on the locale. But unless the pattern is being compiled
if (*temp_ptr == ']') {
temp_ptr++;
if (! found_problem && ! check_only) {
- RExC_parse = (char *) temp_ptr;
+ RExC_parse_set((char *) temp_ptr);
vFAIL3("POSIX syntax [%c %c] is reserved for future "
"extensions", open_char, open_char);
}
const char * const complement_string = (complement)
? "^"
: "";
- RExC_parse = (char *) p;
+ RExC_parse_set((char *) p);
vFAIL3utf8f("POSIX class [:%s%" UTF8f ":] unknown",
complement_string,
UTF8fARG(UTF, RExC_parse - name_start - 2, name_start));
STATIC regnode_offset
S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist,
- I32 *flagp, U32 depth,
- char * const oregcomp_parse)
+ I32 *flagp, U32 depth)
{
/* Handle the (?[...]) construct to do set operations */
DECLARE_AND_GET_RE_DEBUG_FLAGS;
PERL_ARGS_ASSERT_HANDLE_REGEX_SETS;
- PERL_UNUSED_ARG(oregcomp_parse); /* Only for Set_Node_Length */
DEBUG_PARSE("xcls");
* compile time values are valid in all runtime cases */
REQUIRE_UNI_RULES(flagp, 0);
- ckWARNexperimental(RExC_parse,
- WARN_EXPERIMENTAL__REGEX_SETS,
- "The regex_sets feature is experimental");
-
/* Everything in this construct is a metacharacter. Operands begin with
* either a '\' (for an escape sequence), or a '[' for a bracketed
* character class. Any other character should be an operator, or
* with pronouncing it called it Reverse Polish instead, but now that YOU
* know how to pronounce it you can use the correct term, thus giving due
* credit to the person who invented it, and impressing your geek friends.
- * Wikipedia says that the pronounciation of "Ł" has been changing so that
+ * Wikipedia says that the pronunciation of "Ł" has been changing so that
* it is now more like an English initial W (as in wonk) than an L.)
*
* This means that, for example, 'a | b & c' is stored on the stack as
* so that everything gets evaluated down to a single operand, which is the
* result */
- sv_2mortal((SV *)(stack = newAV()));
- sv_2mortal((SV *)(fence_stack = newAV()));
+ stack = (AV*)newSV_type_mortal(SVt_PVAV);
+ fence_stack = (AV*)newSV_type_mortal(SVt_PVAV);
while (RExC_parse < RExC_end) {
I32 top_index; /* Index of top-most element in 'stack' */
if ( RExC_parse < RExC_end - 2
&& UCHARAT(RExC_parse + 1) == '?'
- && UCHARAT(RExC_parse + 2) == '^')
+ && strchr("^" STD_PAT_MODS, *(RExC_parse + 2)))
{
const regnode_offset orig_emit = RExC_emit;
SV * resultant_invlist;
- /* If is a '(?^', could be an embedded '(?^flags:(?[...])'.
+ /* Here it could be an embedded '(?flags:(?[...])'.
* This happens when we have some thing like
*
* my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
* an error: we need to get a single inversion list back
* from the recursion */
- RExC_parse++;
+ RExC_parse_inc_by(1);
RExC_sets_depth++;
- node = reg(pRExC_state, 2, flagp, depth+1);
+ node = reg(pRExC_state, 2, flagp, depth+1);
RETURN_FAIL_ON_RESTART(*flagp, flagp);
if ( OP(REGNODE_p(node)) != REGEX_SET
* which isn't legal */
|| RExC_emit != orig_emit
+ NODE_STEP_REGNODE
- + regarglen[REGEX_SET])
+ + REGNODE_ARG_LEN(REGEX_SET))
{
vFAIL("Expecting interpolated extended charclass");
}
FALSE))
|| ! IS_OPERATOR(*stacked_ptr))))
{
- RExC_parse++;
+ RExC_parse_inc_by(1);
vFAIL("Unexpected '(' with no preceding operator");
}
}
/* Stack the position of this undealt-with left paren */
- av_push(fence_stack, newSViv(fence));
+ av_push_simple(fence_stack, newSViv(fence));
fence = top_index + 1;
break;
* to fool regclass() into thinking it is part of a
* '[[:posix:]]'. */
if (! is_posix_class) {
- RExC_parse++;
+ RExC_parse_inc_by(1);
}
/* regclass() can only return RESTART_PARSE and NEED_UTF8 if
if (UCHARAT(RExC_parse - 1) == ']') {
break;
}
- RExC_parse++;
+ RExC_parse_inc_by(1);
vFAIL("Unexpected ')'");
}
/* If nothing after the fence, is missing an operand */
if (top_index - fence < 0) {
- RExC_parse++;
+ RExC_parse_inc_by(1);
goto bad_syntax;
}
/* If at least two things on the stack, treat this as an
goto handle_operand;
}
- RExC_parse++;
+ RExC_parse_inc_by(1);
goto bad_syntax;
case '&':
/* Place the operator before the operand */
SV* lhs = av_pop(stack);
- av_push(stack, newSVuv(curchar));
- av_push(stack, lhs);
+ av_push_simple(stack, newSVuv(curchar));
+ av_push_simple(stack, lhs);
break;
}
}
unexpected_binary:
- RExC_parse++;
+ RExC_parse_inc_by(1);
vFAIL2("Unexpected binary operator '%c' with no "
"preceding operand", curchar);
}
* */
lhs = av_pop(stack);
assert(IS_OPERAND(lhs));
-
- av_push(stack, newSVuv(curchar));
- av_push(stack, lhs);
+ av_push_simple(stack, newSVuv(curchar));
+ av_push_simple(stack, lhs);
break;
}
* stacked operation */
only_to_avoid_leaks = av_pop(stack);
SvREFCNT_dec(only_to_avoid_leaks);
- av_push(stack, rhs);
+ av_push_simple(stack, rhs);
goto redo_curchar;
case '!': /* Highest priority, right associative */
}
else { /* Otherwise, since it's right associative, just push
onto the stack */
- av_push(stack, newSVuv(curchar));
+ av_push_simple(stack, newSVuv(curchar));
}
break;
default:
- RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
+ RExC_parse_inc();
if (RExC_parse >= RExC_end) {
break;
}
/* Here there was nothing on the stack or the top element was
* another operand. Just add this new one */
- av_push(stack, current);
+ av_push_simple(stack, current);
} /* End of switch on next parse token */
- RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
+ RExC_parse_inc();
} /* End of loop parsing through the construct */
vFAIL("Syntax error in (?[...])");
if (RExC_parse >= RExC_end || RExC_parse[1] != ')') {
if (RExC_parse < RExC_end) {
- RExC_parse++;
+ RExC_parse_inc_by(1);
}
vFAIL("Unexpected ']' with no following ')' in (?[...");
if (RExC_sets_depth) { /* If within a recursive call, return in a special
regnode */
- RExC_parse++;
+ RExC_parse_inc_by(1);
node = regpnode(pRExC_state, REGEX_SET, final);
}
else {
/* About to generate an ANYOF (or similar) node from the inversion list
* we have calculated */
save_parse = RExC_parse;
- RExC_parse = SvPV(result_string, len);
+ RExC_parse_set(SvPV(result_string, len));
save_end = RExC_end;
RExC_end = RExC_parse + len;
TURN_OFF_WARNINGS_IN_SUBSTITUTE_PARSE;
);
RESTORE_WARNINGS;
- RExC_parse = save_parse + 1;
+ RExC_parse_set(save_parse + 1);
RExC_end = save_end;
SvREFCNT_dec_NN(final);
SvREFCNT_dec_NN(result_string);
assert(OP(REGNODE_p(node)) == ANYOF);
OP(REGNODE_p(node)) = ANYOFL;
- ANYOF_FLAGS(REGNODE_p(node))
- |= ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
+ ANYOF_FLAGS(REGNODE_p(node)) |= ANYOFL_UTF8_LOCALE_REQD;
}
}
nextchar(pRExC_state);
- Set_Node_Length(REGNODE_p(node), RExC_parse - oregcomp_parse + 1); /* MJD */
return node;
regclass_failed:
else {
PerlIO_printf(Perl_debug_log, "Fence_stack: \n");
for (i = fence_stack_top; i >= 0; i--) {
- SV ** element_ptr = av_fetch(fence_stack, i, FALSE);
+ SV ** element_ptr = av_fetch_simple(fence_stack, i, FALSE);
if (! element_ptr) {
}
#undef IS_OPERATOR
#undef IS_OPERAND
-STATIC void
-S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invlist)
+#ifdef PERL_RE_BUILD_AUX
+void
+Perl_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invlist)
{
/* This adds the Latin1/above-Latin1 folding rules.
*
}
}
}
+#endif /* PERL_RE_BUILD_AUX */
+
STATIC void
S_output_posix_warnings(pTHX_ RExC_state_t *pRExC_state, AV* posix_warnings)
return s1 - start;
}
-
STATIC AV *
S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count)
{
}
if (av_exists(multi_char_matches, cp_count)) {
- this_array_ptr = (AV**) av_fetch(multi_char_matches, cp_count, FALSE);
+ this_array_ptr = (AV**) av_fetch_simple(multi_char_matches, cp_count, FALSE);
this_array = *this_array_ptr;
}
else {
this_array = newAV();
- av_store(multi_char_matches, cp_count,
+ av_store_simple(multi_char_matches, cp_count,
(SV*) this_array);
}
- av_push(this_array, multi_string);
+ av_push_simple(this_array, multi_string);
return multi_char_matches;
}
SV *listsv = NULL; /* List of \p{user-defined} whose definitions
aren't available at the time this was called */
STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
- than just initialized. */
+ than just initialized. */
SV* properties = NULL; /* Code points that match \p{} \P{} */
SV* posixes = NULL; /* Code points that match classes like [:word:],
extended beyond the Latin1 range. These have to
leading to less compilation and execution
work */
UV element_count = 0; /* Number of distinct elements in the class.
- Optimizations may be possible if this is tiny */
+ Optimizations may be possible if this is tiny */
AV * multi_char_matches = NULL; /* Code points that fold to more than one
character; used under /i */
UV n;
/* In a range, if one of the endpoints is non-character-set portable,
* meaning that it hard-codes a code point that may mean a different
- * charactger in ASCII vs. EBCDIC, as opposed to, say, a literal 'A' or a
+ * character in ASCII vs. EBCDIC, as opposed to, say, a literal 'A' or a
* mnemonic '\t' which each mean the same character no matter which
* character set the platform is on. */
unsigned int non_portable_endpoint = 0;
AV* posix_warnings = NULL;
const bool do_posix_warnings = ckWARN(WARN_REGEXP);
- U8 op = END; /* The returned node-type, initialized to an impossible
- one. */
+ U8 op = ANYOF; /* The returned node-type, initialized to the expected
+ type. */
U8 anyof_flags = 0; /* flag bits if the node is an ANYOF-type */
U32 posixl = 0; /* bit field of posix classes matched under /l */
assert(RExC_parse <= RExC_end);
if (UCHARAT(RExC_parse) == '^') { /* Complement the class */
- RExC_parse++;
+ RExC_parse_inc_by(1);
invert = TRUE;
allow_mutiple_chars = FALSE;
MARK_NAUGHTY(1);
/* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
if (UCHARAT(RExC_parse) == ']')
- goto charclassloop;
+ goto charclassloop;
while (1) {
charclassloop:
- namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
+ namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
save_value = value;
save_prevvalue = prevvalue;
- if (!range) {
- rangebegin = RExC_parse;
- element_count++;
+ if (!range) {
+ rangebegin = RExC_parse;
+ element_count++;
non_portable_endpoint = 0;
- }
- if (UTF && ! UTF8_IS_INVARIANT(* RExC_parse)) {
- value = utf8n_to_uvchr((U8*)RExC_parse,
- RExC_end - RExC_parse,
- &numlen, UTF8_ALLOW_DEFAULT);
- RExC_parse += numlen;
- }
- else
- value = UCHARAT(RExC_parse++);
+ }
+ if (UTF && ! UTF8_IS_INVARIANT(* RExC_parse)) {
+ value = utf8n_to_uvchr((U8*)RExC_parse,
+ RExC_end - RExC_parse,
+ &numlen, UTF8_ALLOW_DEFAULT);
+ RExC_parse_inc_by(numlen);
+ }
+ else {
+ value = UCHARAT(RExC_parse);
+ RExC_parse_inc_by(1);
+ }
if (value == '[') {
char * posix_class_end;
av_undef(posix_warnings);
}
- RExC_parse = posix_class_end;
+ RExC_parse_set(posix_class_end);
}
else if (namedclass == OOB_NAMEDCLASS) {
not_posix_region_end = posix_class_end;
TRUE /* checking only */);
}
else if ( strict && ! skip_white
- && ( _generic_isCC(value, _CC_VERTSPACE)
+ && ( generic_isCC_(value, CC_VERTSPACE_)
|| is_VERTWS_cp_high(value)))
{
vFAIL("Literal vertical space in [] is illegal except under /x");
vFAIL("Unmatched [");
}
- if (UTF && ! UTF8_IS_INVARIANT(UCHARAT(RExC_parse))) {
- value = utf8n_to_uvchr((U8*)RExC_parse,
- RExC_end - RExC_parse,
- &numlen, UTF8_ALLOW_DEFAULT);
- RExC_parse += numlen;
- }
- else
- value = UCHARAT(RExC_parse++);
+ if (UTF && ! UTF8_IS_INVARIANT(UCHARAT(RExC_parse))) {
+ value = utf8n_to_uvchr((U8*)RExC_parse,
+ RExC_end - RExC_parse,
+ &numlen, UTF8_ALLOW_DEFAULT);
+ RExC_parse_inc_by(numlen);
+ }
+ else {
+ value = UCHARAT(RExC_parse);
+ RExC_parse_inc_by(1);
+ }
- /* Some compilers cannot handle switching on 64-bit integer
- * values, therefore value cannot be an UV. Yes, this will
- * be a problem later if we want switch on Unicode.
- * A similar issue a little bit later when switching on
- * namedclass. --jhi */
+ /* Some compilers cannot handle switching on 64-bit integer
+ * values, therefore value cannot be an UV. Yes, this will
+ * be a problem later if we want switch on Unicode.
+ * A similar issue a little bit later when switching on
+ * namedclass. --jhi */
/* If the \ is escaping white space when white space is being
* skipped, it means that that white space is wanted literally, and
U32 packed_warn;
U8 grok_c_char;
- case 'w': namedclass = ANYOF_WORDCHAR; break;
- case 'W': namedclass = ANYOF_NWORDCHAR; break;
- case 's': namedclass = ANYOF_SPACE; break;
- case 'S': namedclass = ANYOF_NSPACE; break;
- case 'd': namedclass = ANYOF_DIGIT; break;
- case 'D': namedclass = ANYOF_NDIGIT; break;
- case 'v': namedclass = ANYOF_VERTWS; break;
- case 'V': namedclass = ANYOF_NVERTWS; break;
- case 'h': namedclass = ANYOF_HORIZWS; break;
- case 'H': namedclass = ANYOF_NHORIZWS; break;
+ case 'w': namedclass = ANYOF_WORDCHAR; break;
+ case 'W': namedclass = ANYOF_NWORDCHAR; break;
+ case 's': namedclass = ANYOF_SPACE; break;
+ case 'S': namedclass = ANYOF_NSPACE; break;
+ case 'd': namedclass = ANYOF_DIGIT; break;
+ case 'D': namedclass = ANYOF_NDIGIT; break;
+ case 'v': namedclass = ANYOF_VERTWS; break;
+ case 'V': namedclass = ANYOF_NVERTWS; break;
+ case 'h': namedclass = ANYOF_HORIZWS; break;
+ case 'H': namedclass = ANYOF_NHORIZWS; break;
case 'N': /* Handle \N{NAME} in class */
{
const char * const backslash_N_beg = RExC_parse - 2;
unicode_range = TRUE; /* \N{} are Unicode */
}
break;
- case 'p':
- case 'P':
- {
- char *e;
+ case 'p':
+ case 'P':
+ {
+ char *e;
if (RExC_pm_flags & PMf_WILDCARD) {
- RExC_parse++;
+ RExC_parse_inc_by(1);
/* diag_listed_as: Use of %s is not allowed in Unicode
property wildcard subpatterns in regex; marked by <--
HERE in m/%s/ */
" wildcard subpatterns", (char) value, *(RExC_parse - 1));
}
- /* \p means they want Unicode semantics */
- REQUIRE_UNI_RULES(flagp, 0);
+ /* \p means they want Unicode semantics */
+ REQUIRE_UNI_RULES(flagp, 0);
- if (RExC_parse >= RExC_end)
- vFAIL2("Empty \\%c", (U8)value);
- if (*RExC_parse == '{') {
- const U8 c = (U8)value;
- e = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse);
+ if (RExC_parse >= RExC_end)
+ vFAIL2("Empty \\%c", (U8)value);
+ if (*RExC_parse == '{') {
+ const U8 c = (U8)value;
+ e = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse);
if (!e) {
- RExC_parse++;
+ RExC_parse_inc_by(1);
vFAIL2("Missing right brace on \\%c{}", c);
}
- RExC_parse++;
+ RExC_parse_inc_by(1);
/* White space is allowed adjacent to the braces and after
* any '^', even when not under /x */
while (isSPACE(*RExC_parse)) {
- RExC_parse++;
- }
+ RExC_parse_inc_by(1);
+ }
- if (UCHARAT(RExC_parse) == '^') {
+ if (UCHARAT(RExC_parse) == '^') {
/* toggle. (The rhs xor gets the single bit that
* differs between P and p; the other xor inverts just
* that bit) */
value ^= 'P' ^ 'p';
- RExC_parse++;
+ RExC_parse_inc_by(1);
while (isSPACE(*RExC_parse)) {
- RExC_parse++;
+ RExC_parse_inc_by(1);
}
}
if (e == RExC_parse)
vFAIL2("Empty \\%c{}", c);
- n = e - RExC_parse;
- while (isSPACE(*(RExC_parse + n - 1)))
- n--;
+ n = e - RExC_parse;
+ while (isSPACE(*(RExC_parse + n - 1)))
+ n--;
- } /* The \p isn't immediately followed by a '{' */
- else if (! isALPHA(*RExC_parse)) {
- RExC_parse += (UTF)
- ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
- : 1;
+ } /* The \p isn't immediately followed by a '{' */
+ else if (! isALPHA(*RExC_parse)) {
+ RExC_parse_inc_safe();
vFAIL2("Character following \\%c must be '{' or a "
"single-character Unicode property name",
(U8) value);
}
else {
- e = RExC_parse;
- n = 1;
- }
- {
+ e = RExC_parse;
+ n = 1;
+ }
+ {
char* name = RExC_parse;
/* Any message returned about expanding the definition */
);
if (SvCUR(msg)) { /* Assumes any error causes a msg */
assert(prop_definition == NULL);
- RExC_parse = e + 1;
+ RExC_parse_set(e + 1);
if (SvUTF8(msg)) { /* msg being UTF-8 makes the whole
thing so, or else the display is
mojibake */
RExC_utf8 = TRUE;
}
- /* diag_listed_as: Can't find Unicode property definition "%s" in regex; marked by <-- HERE in m/%s/ */
+ /* diag_listed_as: Can't find Unicode property definition "%s" in regex; marked by <-- HERE in m/%s/ */
vFAIL2utf8f("%" UTF8f, UTF8fARG(SvUTF8(msg),
SvCUR(msg), SvPVX(msg)));
}
if (strings) {
if (ret_invlist) {
if (! prop_definition) {
- RExC_parse = e + 1;
+ RExC_parse_set(e + 1);
vFAIL("Unicode string properties are not implemented in (?[...])");
}
else {
}
else if (! RExC_in_multi_char_class) {
if (invert ^ (value == 'P')) {
- RExC_parse = e + 1;
+ RExC_parse_set(e + 1);
vFAIL("Inverting a character class which contains"
" a multi-character sequence is illegal");
}
* points. */
AV * this_string = (AV *) av_shift( strings);
STRLEN cp_count = av_count(this_string);
- SV * final = newSV(cp_count * 4);
- SvPVCLEAR(final);
+ SV * final = newSV(cp_count ? cp_count * 4 : 1);
+ SvPVCLEAR_FRESH(final);
/* Create another string of sequences of \x{...} */
while (av_count(this_string) > 0) {
/* We don't know yet what this matches, so have to flag
* it */
- anyof_flags |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
+ anyof_flags |= ANYOF_HAS_EXTRA_RUNTIME_MATCHES;
}
else {
assert (prop_definition && is_invlist(prop_definition));
/* Here we do have the complete property definition
*
- * Temporary workaround for [perl #133136]. For this
+ * Temporary workaround for [GH #16520]. For this
* precise input that is in the .t that is failing,
* load utf8.pm, which is what the test wants, so that
* that .t passes */
/* Invert if asking for the complement */
if (value == 'P') {
- _invlist_union_complement_2nd(properties,
+ _invlist_union_complement_2nd(properties,
prop_definition,
&properties);
}
else {
_invlist_union(properties, prop_definition, &properties);
- }
+ }
}
}
- RExC_parse = e + 1;
+ RExC_parse_set(e + 1);
namedclass = ANYOF_UNIPROP; /* no official name, but it's
named */
- }
- break;
- case 'n': value = '\n'; break;
- case 'r': value = '\r'; break;
- case 't': value = '\t'; break;
- case 'f': value = '\f'; break;
- case 'b': value = '\b'; break;
- case 'e': value = ESC_NATIVE; break;
- case 'a': value = '\a'; break;
- case 'o':
- RExC_parse--; /* function expects to be pointed at the 'o' */
+ }
+ break;
+ case 'n': value = '\n'; break;
+ case 'r': value = '\r'; break;
+ case 't': value = '\t'; break;
+ case 'f': value = '\f'; break;
+ case 'b': value = '\b'; break;
+ case 'e': value = ESC_NATIVE; break;
+ case 'a': value = '\a'; break;
+ case 'o':
+ RExC_parse--; /* function expects to be pointed at the 'o' */
if (! grok_bslash_o(&RExC_parse,
RExC_end,
&value,
if (value < 256) {
non_portable_endpoint++;
}
- break;
- case 'x':
- RExC_parse--; /* function expects to be pointed at the 'x' */
+ break;
+ case 'x':
+ RExC_parse--; /* function expects to be pointed at the 'x' */
if (! grok_bslash_x(&RExC_parse,
RExC_end,
&value,
if (value < 256) {
non_portable_endpoint++;
}
- break;
- case 'c':
+ break;
+ case 'c':
if (! grok_bslash_c(*RExC_parse, &grok_c_char, &message,
&packed_warn))
{
/* going to die anyway; point to exact spot of
* failure */
- RExC_parse += (UTF)
- ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
- : 1;
+ RExC_parse_inc_safe();
vFAIL(message);
}
value = grok_c_char;
- RExC_parse++;
+ RExC_parse_inc_by(1);
if (message && TO_OUTPUT_WARNINGS(RExC_parse)) {
warn_non_literal_string(RExC_parse, packed_warn, message);
}
non_portable_endpoint++;
- break;
- case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7':
- {
- /* Take 1-3 octal digits */
- I32 flags = PERL_SCAN_SILENT_ILLDIGIT
+ break;
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7':
+ {
+ /* Take 1-3 octal digits */
+ I32 flags = PERL_SCAN_SILENT_ILLDIGIT
| PERL_SCAN_NOTIFY_ILLDIGIT;
numlen = (strict) ? 4 : 3;
value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
- RExC_parse += numlen;
+ RExC_parse_inc_by(numlen);
if (numlen != 3) {
if (strict) {
- RExC_parse += (UTF)
- ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
- : 1;
+ RExC_parse_inc_safe();
vFAIL("Need exactly 3 octal digits");
}
else if ( (flags & PERL_SCAN_NOTIFY_ILLDIGIT)
if (value < 256) {
non_portable_endpoint++;
}
- break;
- }
- default:
- /* Allow \_ to not give an error */
- if (isWORDCHAR(value) && value != '_') {
+ break;
+ }
+ default:
+ /* Allow \_ to not give an error */
+ if (isWORDCHAR(value) && value != '_') {
if (strict) {
vFAIL2("Unrecognized escape \\%c in character class",
(int)value);
"Unrecognized escape \\%c in character class passed through",
(int)value);
}
- }
- break;
- } /* End of switch on char following backslash */
- } /* end of handling backslash escape sequences */
+ }
+ break;
+ } /* End of switch on char following backslash */
+ } /* end of handling backslash escape sequences */
/* Here, we have the current token in 'value' */
- if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
+ if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
U8 classnum;
- /* a bad range like a-\d, a-[:digit:]. The '-' is taken as a
- * literal, as is the character that began the false range, i.e.
- * the 'a' in the examples */
- if (range) {
+ /* a bad range like a-\d, a-[:digit:]. The '-' is taken as a
+ * literal, as is the character that began the false range, i.e.
+ * the 'a' in the examples */
+ if (range) {
const int w = (RExC_parse >= rangebegin)
? RExC_parse - rangebegin
: 0;
prevvalue);
}
- range = 0; /* this was not a true range */
+ range = 0; /* this was not a true range */
element_count += 2; /* So counts for three values */
- }
+ }
classnum = namedclass_to_classnum(namedclass);
- if (LOC && namedclass < ANYOF_POSIXL_MAX
+ if (LOC && namedclass < ANYOF_POSIXL_MAX
#ifndef HAS_ISASCII
- && classnum != _CC_ASCII
+ && classnum != CC_ASCII_
#endif
) {
SV* scratch_list = NULL;
/* Here, should be \h, \H, \v, or \V. None of /d, /i
* nor /l make a difference in what these match,
* therefore we just add what they match to cp_list. */
- if (classnum != _CC_VERTSPACE) {
+ if (classnum != CC_VERTSPACE_) {
assert( namedclass == ANYOF_HORIZWS
|| namedclass == ANYOF_NHORIZWS);
/* It turns out that \h is just a synonym for
* XPosixBlank */
- classnum = _CC_BLANK;
+ classnum = CC_BLANK_;
}
_invlist_union_maybe_complement_2nd(
}
}
else if ( AT_LEAST_UNI_SEMANTICS
- || classnum == _CC_ASCII
- || (DEPENDS_SEMANTICS && ( classnum == _CC_DIGIT
- || classnum == _CC_XDIGIT)))
+ || classnum == CC_ASCII_
+ || (DEPENDS_SEMANTICS && ( classnum == CC_DIGIT_
+ || classnum == CC_XDIGIT_)))
{
/* We usually have to worry about /d affecting what POSIX
* classes match, with special code needed because we won't
namedclass % 2 != 0,
posixes_ptr);
}
- }
- } /* end of namedclass \blah */
+ }
+ } /* end of namedclass \blah */
SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse, RExC_end);
* the next real character to be processed is the range indicator--the
* minus sign */
- if (range) {
+ if (range) {
#ifdef EBCDIC
/* For unicode ranges, we have to test that the Unicode as opposed
* to the native values are not decreasing. (Above 255, there is
* no difference between native and Unicode) */
- if (unicode_range && prevvalue < 255 && value < 255) {
+ if (unicode_range && prevvalue < 255 && value < 255) {
if (NATIVE_TO_LATIN1(prevvalue) > NATIVE_TO_LATIN1(value)) {
goto backwards_range;
}
}
else
#endif
- if (prevvalue > value) /* b-a */ {
- int w;
+ if (prevvalue > value) /* b-a */ {
+ int w;
#ifdef EBCDIC
backwards_range:
#endif
"Invalid [] range \"%" UTF8f "\"",
UTF8fARG(UTF, w, rangebegin));
NOT_REACHED; /* NOTREACHED */
- }
- }
- else {
+ }
+ }
+ else {
prevvalue = value; /* save the beginning of the potential range */
if (! stop_at_1 /* Can't be a range if parsing just one thing */
&& *RExC_parse == '-')
/* If the '-' is at the end of the class (just before the ']',
* it is a literal minus; otherwise it is a range */
if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
- RExC_parse = next_char_ptr;
+ RExC_parse_set(next_char_ptr);
/* a bad range like \w-, [:word:]- ? */
if (namedclass > OOB_NAMEDCLASS) {
range = 1; /* yeah, it's a range! */
continue; /* but do it the next time */
}
- }
- }
+ }
+ }
if (namedclass > OOB_NAMEDCLASS) {
continue;
* <prevvalue> is the beginning of the range, if any; or <value> if
* not. */
- /* non-Latin1 code point implies unicode semantics. */
- if (value > 255) {
+ /* non-Latin1 code point implies unicode semantics. */
+ if (value > 255) {
if (value > MAX_LEGAL_CP && ( value != UV_MAX
|| prevvalue > MAX_LEGAL_CP))
{
PL_extended_cp_format,
value);
}
- }
+ }
/* Ready to process either the single value, or the completed range.
* For single-valued non-inverted ranges, we consider the possibility
if (! RExC_in_multi_char_class) {
STRLEN cp_count = utf8_length(foldbuf,
foldbuf + foldlen);
- SV* multi_fold = sv_2mortal(newSVpvs(""));
+ SV* multi_fold = newSVpvs_flags("", SVs_TEMP);
Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%" UVXf "}", value);
* are in the same series, which is the same range.
* */
index_start = _invlist_search(
- PL_XPosix_ptrs[_CC_DIGIT],
+ PL_XPosix_ptrs[CC_DIGIT_],
prevvalue);
/* Warn if the range starts and ends with a digit,
if ( index_start >= 0
&& ELEMENT_RANGE_MATCHES_INVLIST(index_start)
&& (index_final =
- _invlist_search(PL_XPosix_ptrs[_CC_DIGIT],
+ _invlist_search(PL_XPosix_ptrs[CC_DIGIT_],
value)) != index_start
&& index_final >= 0
&& ELEMENT_RANGE_MATCHES_INVLIST(index_final))
}
#endif
- range = 0; /* this range (if it was one) is done now */
+ range = 0; /* this range (if it was one) is done now */
} /* End of loop through all the text within the brackets */
if ( posix_warnings && av_tindex_skip_len_mg(posix_warnings) >= 0) {
* deal with them by building up a substitute parse string, and recursively
* calling reg() on it, instead of proceeding */
if (multi_char_matches) {
- SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
+ SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
I32 cp_count;
- STRLEN len;
- char *save_end = RExC_end;
- char *save_parse = RExC_parse;
- char *save_start = RExC_start;
+ STRLEN len;
+ char *save_end = RExC_end;
+ char *save_parse = RExC_parse;
+ char *save_start = RExC_start;
Size_t constructed_prefix_len = 0; /* This gives the length of the
constructed portion of the
substitute parse. */
AV** this_array_ptr;
SV* this_sequence;
- this_array_ptr = (AV**) av_fetch(multi_char_matches,
+ this_array_ptr = (AV**) av_fetch_simple(multi_char_matches,
cp_count, FALSE);
while ((this_sequence = av_pop(*this_array_ptr)) !=
&PL_sv_undef)
* reported. See the comments at the definition of
* REPORT_LOCATION_ARGS for details */
RExC_copy_start_in_input = (char *) orig_parse;
- RExC_start = RExC_parse = SvPV(substitute_parse, len);
+ RExC_start = SvPV(substitute_parse, len);
+ RExC_parse_set( RExC_start );
RExC_copy_start_in_constructed = RExC_start + constructed_prefix_len;
- RExC_end = RExC_parse + len;
+ RExC_end = RExC_parse + len;
RExC_in_multi_char_class = 1;
- ret = reg(pRExC_state, 1, ®_flags, depth+1);
+ ret = reg(pRExC_state, 1, ®_flags, depth+1);
*flagp |= reg_flags & (HASWIDTH|SIMPLE|POSTPONED|RESTART_PARSE|NEED_UTF8);
/* And restore so can parse the rest of the pattern */
- RExC_parse = save_parse;
- RExC_start = RExC_copy_start_in_constructed = RExC_copy_start_in_input = save_start;
- RExC_end = save_end;
- RExC_in_multi_char_class = 0;
+ RExC_parse_set(save_parse);
+ RExC_start = RExC_copy_start_in_constructed = RExC_copy_start_in_input = save_start;
+ RExC_end = save_end;
+ RExC_in_multi_char_class = 0;
SvREFCNT_dec_NN(multi_char_matches);
+ SvREFCNT_dec(properties);
+ SvREFCNT_dec(cp_list);
+ SvREFCNT_dec(simple_posixes);
+ SvREFCNT_dec(posixes);
+ SvREFCNT_dec(nposixes);
+ SvREFCNT_dec(cp_foldable_list);
return ret;
}
/* Now that we have finished adding all the folds, there is no reason
* to keep the foldable list separate */
_invlist_union(cp_list, cp_foldable_list, &cp_list);
- SvREFCNT_dec_NN(cp_foldable_list);
+ SvREFCNT_dec_NN(cp_foldable_list);
}
/* And combine the result (if any) with any inversion lists from posix
_invlist_subtract(only_non_utf8_list, cp_list,
&only_non_utf8_list);
if (_invlist_len(only_non_utf8_list) != 0) {
- anyof_flags |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
+ anyof_flags |= ANYOFD_NON_UTF8_MATCHES_ALL_NON_ASCII__shared;
}
SvREFCNT_dec_NN(only_non_utf8_list);
}
* the issues involved */
if (warn_super) {
warn_super = ! (invert
- ^ (invlist_highest(cp_list) > PERL_UNICODE_MAX));
+ ^ (UNICODE_IS_SUPER(invlist_highest(cp_list))));
}
_invlist_union(properties, cp_list, &cp_list);
}
if (warn_super) {
- anyof_flags
- |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
+ anyof_flags |= ANYOF_WARN_SUPER__shared;
/* Because an ANYOF node is the only one that warns, this node
* can't be optimized into something else */
}
}
if ( only_utf8_locale_list
- || (cp_list && ( _invlist_contains_cp(cp_list, LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE)
- || _invlist_contains_cp(cp_list, LATIN_SMALL_LETTER_DOTLESS_I))))
+ || ( cp_list
+ && ( _invlist_contains_cp(cp_list,
+ LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE)
+ || _invlist_contains_cp(cp_list,
+ LATIN_SMALL_LETTER_DOTLESS_I))))
{
has_runtime_dependency |= HAS_L_RUNTIME_DEPENDENCY;
- anyof_flags
- |= ANYOFL_FOLD
- | ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
+ anyof_flags |= ANYOFL_FOLD|ANYOF_HAS_EXTRA_RUNTIME_MATCHES;
}
else if (cp_list && invlist_lowest(cp_list) < 256) {
/* If nothing is below 256, has no locale dependency; otherwise it
* does */
anyof_flags |= ANYOFL_FOLD;
has_runtime_dependency |= HAS_L_RUNTIME_DEPENDENCY;
+
+ /* In a Turkish locale these could match, notify the run-time code
+ * to check for that */
+ if ( _invlist_contains_cp(cp_list, 'I')
+ || _invlist_contains_cp(cp_list, 'i'))
+ {
+ anyof_flags |= ANYOFL_FOLD|ANYOF_HAS_EXTRA_RUNTIME_MATCHES;
+ }
}
}
else if ( DEPENDS_SEMANTICS
&& ( upper_latin1_only_utf8_matches
- || (anyof_flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)))
+ || ( anyof_flags
+ & ANYOFD_NON_UTF8_MATCHES_ALL_NON_ASCII__shared)))
{
RExC_seen_d_op = TRUE;
has_runtime_dependency |= HAS_D_RUNTIME_DEPENDENCY;
{
_invlist_invert(cp_list);
- /* Clear the invert flag since have just done it here */
- invert = FALSE;
+ /* Clear the invert flag since have just done it here */
+ invert = FALSE;
}
/* All possible optimizations below still have these characteristics.
RExC_contains_locale = 1;
}
- /* Some character classes are equivalent to other nodes. Such nodes take
- * up less room, and some nodes require fewer operations to execute, than
- * ANYOF nodes. EXACTish nodes may be joinable with adjacent nodes to
- * improve efficiency. */
-
if (optimizable) {
- PERL_UINT_FAST8_T i;
- UV partial_cp_count = 0;
- UV start[MAX_FOLD_FROMS+1] = { 0 }; /* +1 for the folded-to char */
- UV end[MAX_FOLD_FROMS+1] = { 0 };
- bool single_range = FALSE;
- if (cp_list) { /* Count the code points in enough ranges that we would
- see all the ones possible in any fold in this version
- of Unicode */
+ /* Some character classes are equivalent to other nodes. Such nodes
+ * take up less room, and some nodes require fewer operations to
+ * execute, than ANYOF nodes. EXACTish nodes may be joinable with
+ * adjacent nodes to improve efficiency. */
+ op = optimize_regclass(pRExC_state, cp_list,
+ only_utf8_locale_list,
+ upper_latin1_only_utf8_matches,
+ has_runtime_dependency,
+ posixl,
+ &anyof_flags, &invert, &ret, flagp);
+ RETURN_FAIL_ON_RESTART_FLAGP(flagp);
- invlist_iterinit(cp_list);
- for (i = 0; i <= MAX_FOLD_FROMS; i++) {
- if (! invlist_iternext(cp_list, &start[i], &end[i])) {
- break;
- }
- partial_cp_count += end[i] - start[i] + 1;
- }
+ /* If optimized to something else and emitted, clean up and return */
+ if (ret >= 0) {
+ SvREFCNT_dec(cp_list);;
+ SvREFCNT_dec(only_utf8_locale_list);
+ SvREFCNT_dec(upper_latin1_only_utf8_matches);
+ return ret;
+ }
- if (i == 1) {
- single_range = TRUE;
+ /* If no optimization was found, an END was returned and we will now
+ * emit an ANYOF */
+ if (op == END) {
+ op = ANYOF;
+ }
+ }
+
+ /* Here are going to emit an ANYOF; set the particular type */
+ if (op == ANYOF) {
+ if (has_runtime_dependency & HAS_D_RUNTIME_DEPENDENCY) {
+ op = ANYOFD;
+ }
+ else if (posixl) {
+ op = ANYOFPOSIXL;
+ }
+ else if (LOC) {
+ op = ANYOFL;
+ }
+ }
+
+ ret = REGNODE_GUTS(pRExC_state, op, REGNODE_ARG_LEN(op));
+ FILL_NODE(ret, op); /* We set the argument later */
+ RExC_emit += NODE_STEP_REGNODE + REGNODE_ARG_LEN(op);
+ ANYOF_FLAGS(REGNODE_p(ret)) = anyof_flags;
+
+ /* Here, <cp_list> contains all the code points we can determine at
+ * compile time that match under all conditions. Go through it, and
+ * for things that belong in the bitmap, put them there, and delete from
+ * <cp_list>. While we are at it, see if everything above 255 is in the
+ * list, and if so, set a flag to speed up execution */
+
+ populate_anyof_bitmap_from_invlist(REGNODE_p(ret), &cp_list);
+
+ if (posixl) {
+ ANYOF_POSIXL_SET_TO_BITMAP(REGNODE_p(ret), posixl);
+ }
+
+ if (invert) {
+ ANYOF_FLAGS(REGNODE_p(ret)) |= ANYOF_INVERT;
+ }
+
+ /* Here, the bitmap has been populated with all the Latin1 code points that
+ * always match. Can now add to the overall list those that match only
+ * when the target string is UTF-8 (<upper_latin1_only_utf8_matches>).
+ * */
+ if (upper_latin1_only_utf8_matches) {
+ if (cp_list) {
+ _invlist_union(cp_list,
+ upper_latin1_only_utf8_matches,
+ &cp_list);
+ SvREFCNT_dec_NN(upper_latin1_only_utf8_matches);
+ }
+ else {
+ cp_list = upper_latin1_only_utf8_matches;
+ }
+ ANYOF_FLAGS(REGNODE_p(ret)) |= ANYOF_HAS_EXTRA_RUNTIME_MATCHES;
+ }
+
+ set_ANYOF_arg(pRExC_state, REGNODE_p(ret), cp_list,
+ (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
+ ? listsv
+ : NULL,
+ only_utf8_locale_list);
+
+ SvREFCNT_dec(cp_list);;
+ SvREFCNT_dec(only_utf8_locale_list);
+ return ret;
+}
+
+STATIC U8
+S_optimize_regclass(pTHX_
+ RExC_state_t *pRExC_state,
+ SV * cp_list,
+ SV* only_utf8_locale_list,
+ SV* upper_latin1_only_utf8_matches,
+ const U32 has_runtime_dependency,
+ const U32 posixl,
+ U8 * anyof_flags,
+ bool * invert,
+ regnode_offset * ret,
+ I32 *flagp
+ )
+{
+ /* This function exists just to make S_regclass() smaller. It extracts out
+ * the code that looks for potential optimizations away from a full generic
+ * ANYOF node. The parameter names are the same as the corresponding
+ * variables in S_regclass.
+ *
+ * It returns the new op (the impossible END one if no optimization found)
+ * and sets *ret to any created regnode. If the new op is sufficiently
+ * like plain ANYOF, it leaves *ret unchanged for allocation in S_regclass.
+ *
+ * Certain of the parameters may be updated as a result of the changes
+ * herein */
+
+ U8 op = END; /* The returned node-type, initialized to an impossible
+ one. */
+ UV value = 0;
+ PERL_UINT_FAST8_T i;
+ UV partial_cp_count = 0;
+ UV start[MAX_FOLD_FROMS+1] = { 0 }; /* +1 for the folded-to char */
+ UV end[MAX_FOLD_FROMS+1] = { 0 };
+ bool single_range = FALSE;
+ UV lowest_cp = 0, highest_cp = 0;
+
+ PERL_ARGS_ASSERT_OPTIMIZE_REGCLASS;
+
+ if (cp_list) { /* Count the code points in enough ranges that we would see
+ all the ones possible in any fold in this version of
+ Unicode */
+
+ invlist_iterinit(cp_list);
+ for (i = 0; i <= MAX_FOLD_FROMS; i++) {
+ if (! invlist_iternext(cp_list, &start[i], &end[i])) {
+ break;
}
- invlist_iterfinish(cp_list);
+ partial_cp_count += end[i] - start[i] + 1;
}
+ if (i == 1) {
+ single_range = TRUE;
+ }
+ invlist_iterfinish(cp_list);
+
/* If we know at compile time that this matches every possible code
* point, any run-time dependencies don't matter */
if (start[0] == 0 && end[0] == UV_MAX) {
- if (invert) {
- ret = reganode(pRExC_state, OPFAIL, 0);
+ if (*invert) {
+ goto return_OPFAIL;
}
else {
- ret = reg_node(pRExC_state, SANY);
- MARK_NAUGHTY(1);
+ goto return_SANY;
}
- goto not_anyof;
}
- /* Similarly, for /l posix classes, if both a class and its
- * complement match, any run-time dependencies don't matter */
- if (posixl) {
- for (namedclass = 0; namedclass < ANYOF_POSIXL_MAX;
- namedclass += 2)
+ /* Use a clearer mnemonic for below */
+ lowest_cp = start[0];
+
+ highest_cp = invlist_highest(cp_list);
+ }
+
+ /* Similarly, for /l posix classes, if both a class and its complement
+ * match, any run-time dependencies don't matter */
+ if (posixl) {
+ int namedclass;
+ for (namedclass = 0; namedclass < ANYOF_POSIXL_MAX; namedclass += 2) {
+ if ( POSIXL_TEST(posixl, namedclass) /* class */
+ && POSIXL_TEST(posixl, namedclass + 1)) /* its complement */
{
- if ( POSIXL_TEST(posixl, namedclass) /* class */
- && POSIXL_TEST(posixl, namedclass + 1)) /* its complement */
- {
- if (invert) {
- ret = reganode(pRExC_state, OPFAIL, 0);
- }
- else {
- ret = reg_node(pRExC_state, SANY);
- MARK_NAUGHTY(1);
- }
- goto not_anyof;
+ if (*invert) {
+ goto return_OPFAIL;
}
+ goto return_SANY;
}
+ }
- /* For well-behaved locales, some classes are subsets of others,
- * so complementing the subset and including the non-complemented
- * superset should match everything, like [\D[:alnum:]], and
- * [[:^alpha:][:alnum:]], but some implementations of locales are
- * buggy, and khw thinks its a bad idea to have optimization change
- * behavior, even if it avoids an OS bug in a given case */
+ /* For well-behaved locales, some classes are subsets of others, so
+ * complementing the subset and including the non-complemented superset
+ * should match everything, like [\D[:alnum:]], and
+ * [[:^alpha:][:alnum:]], but some implementations of locales are
+ * buggy, and khw thinks its a bad idea to have optimization change
+ * behavior, even if it avoids an OS bug in a given case */
#define isSINGLE_BIT_SET(n) isPOWER_OF_2(n)
- /* If is a single posix /l class, can optimize to just that op.
- * Such a node will not match anything in the Latin1 range, as that
- * is not determinable until runtime, but will match whatever the
- * class does outside that range. (Note that some classes won't
- * match anything outside the range, like [:ascii:]) */
- if ( isSINGLE_BIT_SET(posixl)
- && (partial_cp_count == 0 || start[0] > 255))
- {
- U8 classnum;
- SV * class_above_latin1 = NULL;
- bool already_inverted;
- bool are_equivalent;
-
- /* Compute which bit is set, which is the same thing as, e.g.,
- * ANYOF_CNTRL. From
- * https://graphics.stanford.edu/~seander/bithacks.html#IntegerLogDeBruijn
- * */
- static const int MultiplyDeBruijnBitPosition2[32] =
- {
- 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8,
- 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9
- };
+ /* If is a single posix /l class, can optimize to just that op. Such a
+ * node will not match anything in the Latin1 range, as that is not
+ * determinable until runtime, but will match whatever the class does
+ * outside that range. (Note that some classes won't match anything
+ * outside the range, like [:ascii:]) */
+ if ( isSINGLE_BIT_SET(posixl)
+ && (partial_cp_count == 0 || lowest_cp > 255))
+ {
+ U8 classnum;
+ SV * class_above_latin1 = NULL;
+ bool already_inverted;
+ bool are_equivalent;
- namedclass = MultiplyDeBruijnBitPosition2[(posixl
- * 0x077CB531U) >> 27];
- classnum = namedclass_to_classnum(namedclass);
- /* The named classes are such that the inverted number is one
- * larger than the non-inverted one */
- already_inverted = namedclass
- - classnum_to_namedclass(classnum);
+ namedclass = single_1bit_pos32(posixl);
+ classnum = namedclass_to_classnum(namedclass);
- /* Create an inversion list of the official property, inverted
- * if the constructed node list is inverted, and restricted to
- * only the above latin1 code points, which are the only ones
- * known at compile time */
- _invlist_intersection_maybe_complement_2nd(
- PL_AboveLatin1,
- PL_XPosix_ptrs[classnum],
- already_inverted,
- &class_above_latin1);
- are_equivalent = _invlistEQ(class_above_latin1, cp_list,
- FALSE);
- SvREFCNT_dec_NN(class_above_latin1);
+ /* The named classes are such that the inverted number is one
+ * larger than the non-inverted one */
+ already_inverted = namedclass - classnum_to_namedclass(classnum);
- if (are_equivalent) {
+ /* Create an inversion list of the official property, inverted if
+ * the constructed node list is inverted, and restricted to only
+ * the above latin1 code points, which are the only ones known at
+ * compile time */
+ _invlist_intersection_maybe_complement_2nd(
+ PL_AboveLatin1,
+ PL_XPosix_ptrs[classnum],
+ already_inverted,
+ &class_above_latin1);
+ are_equivalent = _invlistEQ(class_above_latin1, cp_list, FALSE);
+ SvREFCNT_dec_NN(class_above_latin1);
- /* Resolve the run-time inversion flag with this possibly
- * inverted class */
- invert = invert ^ already_inverted;
+ if (are_equivalent) {
- ret = reg_node(pRExC_state,
- POSIXL + invert * (NPOSIXL - POSIXL));
- FLAGS(REGNODE_p(ret)) = classnum;
- goto not_anyof;
- }
- }
- }
+ /* Resolve the run-time inversion flag with this possibly
+ * inverted class */
+ *invert = *invert ^ already_inverted;
- /* khw can't think of any other possible transformation involving
- * these. */
- if (has_runtime_dependency & HAS_USER_DEFINED_PROPERTY) {
- goto is_anyof;
+ op = POSIXL + *invert * (NPOSIXL - POSIXL);
+ *ret = reg_node(pRExC_state, op);
+ FLAGS(REGNODE_p(*ret)) = classnum;
+ return op;
+ }
}
+ }
- if (! has_runtime_dependency) {
+ /* khw can't think of any other possible transformation involving these. */
+ if (has_runtime_dependency & HAS_USER_DEFINED_PROPERTY) {
+ return END;
+ }
- /* If the list is empty, nothing matches. This happens, for
- * example, when a Unicode property that doesn't match anything is
- * the only element in the character class (perluniprops.pod notes
- * such properties). */
- if (partial_cp_count == 0) {
- if (invert) {
- ret = reg_node(pRExC_state, SANY);
- }
- else {
- ret = reganode(pRExC_state, OPFAIL, 0);
- }
+ if (! has_runtime_dependency) {
- goto not_anyof;
+ /* If the list is empty, nothing matches. This happens, for example,
+ * when a Unicode property that doesn't match anything is the only
+ * element in the character class (perluniprops.pod notes such
+ * properties). */
+ if (partial_cp_count == 0) {
+ if (*invert) {
+ goto return_SANY;
}
-
- /* If matches everything but \n */
- if ( start[0] == 0 && end[0] == '\n' - 1
- && start[1] == '\n' + 1 && end[1] == UV_MAX)
- {
- assert (! invert);
- ret = reg_node(pRExC_state, REG_ANY);
- MARK_NAUGHTY(1);
- goto not_anyof;
+ else {
+ goto return_OPFAIL;
}
}
- /* Next see if can optimize classes that contain just a few code points
- * into an EXACTish node. The reason to do this is to let the
- * optimizer join this node with adjacent EXACTish ones, and ANYOF
- * nodes require conversion to code point from UTF-8.
- *
- * An EXACTFish node can be generated even if not under /i, and vice
- * versa. But care must be taken. An EXACTFish node has to be such
- * that it only matches precisely the code points in the class, but we
- * want to generate the least restrictive one that does that, to
- * increase the odds of being able to join with an adjacent node. For
- * example, if the class contains [kK], we have to make it an EXACTFAA
- * node to prevent the KELVIN SIGN from matching. Whether we are under
- * /i or not is irrelevant in this case. Less obvious is the pattern
- * qr/[\x{02BC}]n/i. U+02BC is MODIFIER LETTER APOSTROPHE. That is
- * supposed to match the single character U+0149 LATIN SMALL LETTER N
- * PRECEDED BY APOSTROPHE. And so even though there is no simple fold
- * that includes \X{02BC}, there is a multi-char fold that does, and so
- * the node generated for it must be an EXACTFish one. On the other
- * hand qr/:/i should generate a plain EXACT node since the colon
- * participates in no fold whatsoever, and having it EXACT tells the
- * optimizer the target string cannot match unless it has a colon in
- * it.
- */
- if ( ! posixl
- && ! invert
-
- /* Only try if there are no more code points in the class than
- * in the max possible fold */
- && inRANGE(partial_cp_count, 1, MAX_FOLD_FROMS + 1))
+ /* If matches everything but \n */
+ if ( start[0] == 0 && end[0] == '\n' - 1
+ && start[1] == '\n' + 1 && end[1] == UV_MAX)
{
- if (partial_cp_count == 1 && ! upper_latin1_only_utf8_matches)
- {
- /* We can always make a single code point class into an
- * EXACTish node. */
-
- if (LOC) {
-
- /* Here is /l: Use EXACTL, except if there is a fold not
- * known until runtime so shows as only a single code point
- * here. For code points above 255, we know which can
- * cause problems by having a potential fold to the Latin1
- * range. */
- if ( ! FOLD
- || ( start[0] > 255
- && ! is_PROBLEMATIC_LOCALE_FOLD_cp(start[0])))
- {
- op = EXACTL;
- }
- else {
- op = EXACTFL;
- }
+ assert (! *invert);
+ op = REG_ANY;
+ *ret = reg_node(pRExC_state, op);
+ MARK_NAUGHTY(1);
+ return op;
+ }
+ }
+
+ /* Next see if can optimize classes that contain just a few code points
+ * into an EXACTish node. The reason to do this is to let the optimizer
+ * join this node with adjacent EXACTish ones, and ANYOF nodes require
+ * runtime conversion to code point from UTF-8, which we'd like to avoid.
+ *
+ * An EXACTFish node can be generated even if not under /i, and vice versa.
+ * But care must be taken. An EXACTFish node has to be such that it only
+ * matches precisely the code points in the class, but we want to generate
+ * the least restrictive one that does that, to increase the odds of being
+ * able to join with an adjacent node. For example, if the class contains
+ * [kK], we have to make it an EXACTFAA node to prevent the KELVIN SIGN
+ * from matching. Whether we are under /i or not is irrelevant in this
+ * case. Less obvious is the pattern qr/[\x{02BC}]n/i. U+02BC is MODIFIER
+ * LETTER APOSTROPHE. That is supposed to match the single character U+0149
+ * LATIN SMALL LETTER N PRECEDED BY APOSTROPHE. And so even though there
+ * is no simple fold that includes \X{02BC}, there is a multi-char fold
+ * that does, and so the node generated for it must be an EXACTFish one.
+ * On the other hand qr/:/i should generate a plain EXACT node since the
+ * colon participates in no fold whatsoever, and having it be EXACT tells
+ * the optimizer the target string cannot match unless it has a colon in
+ * it. */
+ if ( ! posixl
+ && ! *invert
+
+ /* Only try if there are no more code points in the class than in
+ * the max possible fold */
+ && inRANGE(partial_cp_count, 1, MAX_FOLD_FROMS + 1))
+ {
+ /* We can always make a single code point class into an EXACTish node.
+ * */
+ if (partial_cp_count == 1 && ! upper_latin1_only_utf8_matches) {
+ if (LOC) {
+
+ /* Here is /l: Use EXACTL, except if there is a fold not known
+ * until runtime so shows as only a single code point here.
+ * For code points above 255, we know which can cause problems
+ * by having a potential fold to the Latin1 range. */
+ if ( ! FOLD
+ || ( lowest_cp > 255
+ && ! is_PROBLEMATIC_LOCALE_FOLD_cp(lowest_cp)))
+ {
+ op = EXACTL;
}
- else if (! FOLD) { /* Not /l and not /i */
- op = (start[0] < 256) ? EXACT : EXACT_REQ8;
- }
- else if (start[0] < 256) { /* /i, not /l, and the code point is
- small */
-
- /* Under /i, it gets a little tricky. A code point that
- * doesn't participate in a fold should be an EXACT node.
- * We know this one isn't the result of a simple fold, or
- * there'd be more than one code point in the list, but it
- * could be part of a multi- character fold. In that case
- * we better not create an EXACT node, as we would wrongly
- * be telling the optimizer that this code point must be in
- * the target string, and that is wrong. This is because
- * if the sequence around this code point forms a
- * multi-char fold, what needs to be in the string could be
- * the code point that folds to the sequence.
- *
- * This handles the case of below-255 code points, as we
- * have an easy look up for those. The next clause handles
- * the above-256 one */
- op = IS_IN_SOME_FOLD_L1(start[0])
- ? EXACTFU
- : EXACT;
- }
- else { /* /i, larger code point. Since we are under /i, and
- have just this code point, we know that it can't
- fold to something else, so PL_InMultiCharFold
- applies to it */
- op = _invlist_contains_cp(PL_InMultiCharFold,
- start[0])
+ else {
+ op = EXACTFL;
+ }
+ }
+ else if (! FOLD) { /* Not /l and not /i */
+ op = (lowest_cp < 256) ? EXACT : EXACT_REQ8;
+ }
+ else if (lowest_cp < 256) { /* /i, not /l, and the code point is
+ small */
+
+ /* Under /i, it gets a little tricky. A code point that
+ * doesn't participate in a fold should be an EXACT node. We
+ * know this one isn't the result of a simple fold, or there'd
+ * be more than one code point in the list, but it could be
+ * part of a multi-character fold. In that case we better not
+ * create an EXACT node, as we would wrongly be telling the
+ * optimizer that this code point must be in the target string,
+ * and that is wrong. This is because if the sequence around
+ * this code point forms a multi-char fold, what needs to be in
+ * the string could be the code point that folds to the
+ * sequence.
+ *
+ * This handles the case of below-255 code points, as we have
+ * an easy look up for those. The next clause handles the
+ * above-256 one */
+ op = IS_IN_SOME_FOLD_L1(lowest_cp)
+ ? EXACTFU
+ : EXACT;
+ }
+ else { /* /i, larger code point. Since we are under /i, and have
+ just this code point, we know that it can't fold to
+ something else, so PL_InMultiCharFold applies to it */
+ op = (_invlist_contains_cp(PL_InMultiCharFold, lowest_cp))
? EXACTFU_REQ8
: EXACT_REQ8;
}
- value = start[0];
- }
- else if ( ! (has_runtime_dependency & ~HAS_D_RUNTIME_DEPENDENCY)
- && _invlist_contains_cp(PL_in_some_fold, start[0]))
- {
- /* Here, the only runtime dependency, if any, is from /d, and
- * the class matches more than one code point, and the lowest
- * code point participates in some fold. It might be that the
- * other code points are /i equivalent to this one, and hence
- * they would representable by an EXACTFish node. Above, we
- * eliminated classes that contain too many code points to be
- * EXACTFish, with the test for MAX_FOLD_FROMS
- *
- * First, special case the ASCII fold pairs, like 'B' and 'b'.
- * We do this because we have EXACTFAA at our disposal for the
- * ASCII range */
- if (partial_cp_count == 2 && isASCII(start[0])) {
-
- /* The only ASCII characters that participate in folds are
- * alphabetics */
- assert(isALPHA(start[0]));
- if ( end[0] == start[0] /* First range is a single
- character, so 2nd exists */
- && isALPHA_FOLD_EQ(start[0], start[1]))
- {
-
- /* Here, is part of an ASCII fold pair */
-
- if ( ASCII_FOLD_RESTRICTED
- || HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(start[0]))
- {
- /* If the second clause just above was true, it
- * means we can't be under /i, or else the list
- * would have included more than this fold pair.
- * Therefore we have to exclude the possibility of
- * whatever else it is that folds to these, by
- * using EXACTFAA */
- op = EXACTFAA;
- }
- else if (HAS_NONLATIN1_FOLD_CLOSURE(start[0])) {
+ value = lowest_cp;
+ }
+ else if ( ! (has_runtime_dependency & ~HAS_D_RUNTIME_DEPENDENCY)
+ && _invlist_contains_cp(PL_in_some_fold, lowest_cp))
+ {
+ /* Here, the only runtime dependency, if any, is from /d, and the
+ * class matches more than one code point, and the lowest code
+ * point participates in some fold. It might be that the other
+ * code points are /i equivalent to this one, and hence they would
+ * be representable by an EXACTFish node. Above, we eliminated
+ * classes that contain too many code points to be EXACTFish, with
+ * the test for MAX_FOLD_FROMS
+ *
+ * First, special case the ASCII fold pairs, like 'B' and 'b'. We
+ * do this because we have EXACTFAA at our disposal for the ASCII
+ * range */
+ if (partial_cp_count == 2 && isASCII(lowest_cp)) {
+
+ /* The only ASCII characters that participate in folds are
+ * alphabetics */
+ assert(isALPHA(lowest_cp));
+ if ( end[0] == start[0] /* First range is a single
+ character, so 2nd exists */
+ && isALPHA_FOLD_EQ(start[0], start[1]))
+ {
+ /* Here, is part of an ASCII fold pair */
- /* Here, there's no simple fold that start[0] is part
- * of, but there is a multi-character one. If we
- * are not under /i, we want to exclude that
- * possibility; if under /i, we want to include it
- * */
- op = (FOLD) ? EXACTFU : EXACTFAA;
- }
- else {
+ if ( ASCII_FOLD_RESTRICTED
+ || HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(lowest_cp))
+ {
+ /* If the second clause just above was true, it means
+ * we can't be under /i, or else the list would have
+ * included more than this fold pair. Therefore we
+ * have to exclude the possibility of whatever else it
+ * is that folds to these, by using EXACTFAA */
+ op = EXACTFAA;
+ }
+ else if (HAS_NONLATIN1_FOLD_CLOSURE(lowest_cp)) {
- /* Here, the only possible fold start[0] particpates in
- * is with start[1]. /i or not isn't relevant */
- op = EXACTFU;
- }
+ /* Here, there's no simple fold that lowest_cp is part
+ * of, but there is a multi-character one. If we are
+ * not under /i, we want to exclude that possibility;
+ * if under /i, we want to include it */
+ op = (FOLD) ? EXACTFU : EXACTFAA;
+ }
+ else {
- value = toFOLD(start[0]);
+ /* Here, the only possible fold lowest_cp participates in
+ * is with start[1]. /i or not isn't relevant */
+ op = EXACTFU;
}
+
+ value = toFOLD(lowest_cp);
}
- else if ( ! upper_latin1_only_utf8_matches
- || ( _invlist_len(upper_latin1_only_utf8_matches)
- == 2
- && PL_fold_latin1[
- invlist_highest(upper_latin1_only_utf8_matches)]
- == start[0]))
- {
- /* Here, the smallest character is non-ascii or there are
- * more than 2 code points matched by this node. Also, we
- * either don't have /d UTF-8 dependent matches, or if we
- * do, they look like they could be a single character that
- * is the fold of the lowest one in the always-match list.
- * This test quickly excludes most of the false positives
- * when there are /d UTF-8 depdendent matches. These are
- * like LATIN CAPITAL LETTER A WITH GRAVE matching LATIN
- * SMALL LETTER A WITH GRAVE iff the target string is
- * UTF-8. (We don't have to worry above about exceeding
- * the array bounds of PL_fold_latin1[] because any code
- * point in 'upper_latin1_only_utf8_matches' is below 256.)
- *
- * EXACTFAA would apply only to pairs (hence exactly 2 code
- * points) in the ASCII range, so we can't use it here to
- * artificially restrict the fold domain, so we check if
- * the class does or does not match some EXACTFish node.
- * Further, if we aren't under /i, and the folded-to
- * character is part of a multi-character fold, we can't do
- * this optimization, as the sequence around it could be
- * that multi-character fold, and we don't here know the
- * context, so we have to assume it is that multi-char
- * fold, to prevent potential bugs.
- *
- * To do the general case, we first find the fold of the
- * lowest code point (which may be higher than the lowest
- * one), then find everything that folds to it. (The data
- * structure we have only maps from the folded code points,
- * so we have to do the earlier step.) */
-
- Size_t foldlen;
- U8 foldbuf[UTF8_MAXBYTES_CASE];
- UV folded = _to_uni_fold_flags(start[0],
- foldbuf, &foldlen, 0);
- U32 first_fold;
- const U32 * remaining_folds;
- Size_t folds_to_this_cp_count = _inverse_folds(
+ }
+ else if ( ! upper_latin1_only_utf8_matches
+ || ( _invlist_len(upper_latin1_only_utf8_matches) == 2
+ && PL_fold_latin1[
+ invlist_highest(upper_latin1_only_utf8_matches)]
+ == lowest_cp))
+ {
+ /* Here, the smallest character is non-ascii or there are more
+ * than 2 code points matched by this node. Also, we either
+ * don't have /d UTF-8 dependent matches, or if we do, they
+ * look like they could be a single character that is the fold
+ * of the lowest one is in the always-match list. This test
+ * quickly excludes most of the false positives when there are
+ * /d UTF-8 depdendent matches. These are like LATIN CAPITAL
+ * LETTER A WITH GRAVE matching LATIN SMALL LETTER A WITH GRAVE
+ * iff the target string is UTF-8. (We don't have to worry
+ * above about exceeding the array bounds of PL_fold_latin1[]
+ * because any code point in 'upper_latin1_only_utf8_matches'
+ * is below 256.)
+ *
+ * EXACTFAA would apply only to pairs (hence exactly 2 code
+ * points) in the ASCII range, so we can't use it here to
+ * artificially restrict the fold domain, so we check if the
+ * class does or does not match some EXACTFish node. Further,
+ * if we aren't under /i, and and the folded-to character is
+ * part of a multi-character fold, we can't do this
+ * optimization, as the sequence around it could be that
+ * multi-character fold, and we don't here know the context, so
+ * we have to assume it is that multi-char fold, to prevent
+ * potential bugs.
+ *
+ * To do the general case, we first find the fold of the lowest
+ * code point (which may be higher than that lowest unfolded
+ * one), then find everything that folds to it. (The data
+ * structure we have only maps from the folded code points, so
+ * we have to do the earlier step.) */
+
+ Size_t foldlen;
+ U8 foldbuf[UTF8_MAXBYTES_CASE];
+ UV folded = _to_uni_fold_flags(lowest_cp, foldbuf, &foldlen, 0);
+ U32 first_fold;
+ const U32 * remaining_folds;
+ Size_t folds_to_this_cp_count = _inverse_folds(
folded,
&first_fold,
&remaining_folds);
- Size_t folds_count = folds_to_this_cp_count + 1;
- SV * fold_list = _new_invlist(folds_count);
- unsigned int i;
-
- /* If there are UTF-8 dependent matches, create a temporary
- * list of what this node matches, including them. */
- SV * all_cp_list = NULL;
- SV ** use_this_list = &cp_list;
-
- if (upper_latin1_only_utf8_matches) {
- all_cp_list = _new_invlist(0);
- use_this_list = &all_cp_list;
- _invlist_union(cp_list,
- upper_latin1_only_utf8_matches,
- use_this_list);
- }
+ Size_t folds_count = folds_to_this_cp_count + 1;
+ SV * fold_list = _new_invlist(folds_count);
+ unsigned int i;
- /* Having gotten everything that participates in the fold
- * containing the lowest code point, we turn that into an
- * inversion list, making sure everything is included. */
- fold_list = add_cp_to_invlist(fold_list, start[0]);
- fold_list = add_cp_to_invlist(fold_list, folded);
- if (folds_to_this_cp_count > 0) {
- fold_list = add_cp_to_invlist(fold_list, first_fold);
- for (i = 0; i + 1 < folds_to_this_cp_count; i++) {
- fold_list = add_cp_to_invlist(fold_list,
- remaining_folds[i]);
- }
+ /* If there are UTF-8 dependent matches, create a temporary
+ * list of what this node matches, including them. */
+ SV * all_cp_list = NULL;
+ SV ** use_this_list = &cp_list;
+
+ if (upper_latin1_only_utf8_matches) {
+ all_cp_list = _new_invlist(0);
+ use_this_list = &all_cp_list;
+ _invlist_union(cp_list,
+ upper_latin1_only_utf8_matches,
+ use_this_list);
+ }
+
+ /* Having gotten everything that participates in the fold
+ * containing the lowest code point, we turn that into an
+ * inversion list, making sure everything is included. */
+ fold_list = add_cp_to_invlist(fold_list, lowest_cp);
+ fold_list = add_cp_to_invlist(fold_list, folded);
+ if (folds_to_this_cp_count > 0) {
+ fold_list = add_cp_to_invlist(fold_list, first_fold);
+ for (i = 0; i + 1 < folds_to_this_cp_count; i++) {
+ fold_list = add_cp_to_invlist(fold_list,
+ remaining_folds[i]);
}
+ }
- /* If the fold list is identical to what's in this ANYOF
- * node, the node can be represented by an EXACTFish one
- * instead */
- if (_invlistEQ(*use_this_list, fold_list,
- 0 /* Don't complement */ )
- ) {
+ /* If the fold list is identical to what's in this ANYOF node,
+ * the node can be represented by an EXACTFish one instead */
+ if (_invlistEQ(*use_this_list, fold_list,
+ 0 /* Don't complement */ )
+ ) {
- /* But, we have to be careful, as mentioned above.
- * Just the right sequence of characters could match
- * this if it is part of a multi-character fold. That
- * IS what we want if we are under /i. But it ISN'T
- * what we want if not under /i, as it could match when
- * it shouldn't. So, when we aren't under /i and this
- * character participates in a multi-char fold, we
- * don't optimize into an EXACTFish node. So, for each
- * case below we have to check if we are folding
- * and if not, if it is not part of a multi-char fold.
- * */
- if (start[0] > 255) { /* Highish code point */
- if (FOLD || ! _invlist_contains_cp(
- PL_InMultiCharFold, folded))
- {
- op = (LOC)
- ? EXACTFLU8
- : (ASCII_FOLD_RESTRICTED)
- ? EXACTFAA
- : EXACTFU_REQ8;
- value = folded;
- }
- } /* Below, the lowest code point < 256 */
- else if ( FOLD
- && folded == 's'
- && DEPENDS_SEMANTICS)
- { /* An EXACTF node containing a single character
- 's', can be an EXACTFU if it doesn't get
- joined with an adjacent 's' */
- op = EXACTFU_S_EDGE;
+ /* But, we have to be careful, as mentioned above. Just
+ * the right sequence of characters could match this if it
+ * is part of a multi-character fold. That IS what we want
+ * if we are under /i. But it ISN'T what we want if not
+ * under /i, as it could match when it shouldn't. So, when
+ * we aren't under /i and this character participates in a
+ * multi-char fold, we don't optimize into an EXACTFish
+ * node. So, for each case below we have to check if we
+ * are folding, and if not, if it is not part of a
+ * multi-char fold. */
+ if (lowest_cp > 255) { /* Highish code point */
+ if (FOLD || ! _invlist_contains_cp(
+ PL_InMultiCharFold, folded))
+ {
+ op = (LOC)
+ ? EXACTFLU8
+ : (ASCII_FOLD_RESTRICTED)
+ ? EXACTFAA
+ : EXACTFU_REQ8;
value = folded;
}
- else if ( FOLD
- || ! HAS_NONLATIN1_FOLD_CLOSURE(start[0]))
- {
- if (upper_latin1_only_utf8_matches) {
- op = EXACTF;
+ } /* Below, the lowest code point < 256 */
+ else if ( FOLD
+ && folded == 's'
+ && DEPENDS_SEMANTICS)
+ { /* An EXACTF node containing a single character 's',
+ can be an EXACTFU if it doesn't get joined with an
+ adjacent 's' */
+ op = EXACTFU_S_EDGE;
+ value = folded;
+ }
+ else if ( FOLD
+ || ! HAS_NONLATIN1_FOLD_CLOSURE(lowest_cp))
+ {
+ if (upper_latin1_only_utf8_matches) {
+ op = EXACTF;
- /* We can't use the fold, as that only matches
- * under UTF-8 */
- value = start[0];
- }
- else if ( UNLIKELY(start[0] == MICRO_SIGN)
- && ! UTF)
- { /* EXACTFUP is a special node for this
- character */
- op = (ASCII_FOLD_RESTRICTED)
- ? EXACTFAA
- : EXACTFUP;
- value = MICRO_SIGN;
- }
- else if ( ASCII_FOLD_RESTRICTED
- && ! isASCII(start[0]))
- { /* For ASCII under /iaa, we can use EXACTFU
- below */
- op = EXACTFAA;
- value = folded;
- }
- else {
- op = EXACTFU;
- value = folded;
- }
+ /* We can't use the fold, as that only matches
+ * under UTF-8 */
+ value = lowest_cp;
+ }
+ else if ( UNLIKELY(lowest_cp == MICRO_SIGN)
+ && ! UTF)
+ { /* EXACTFUP is a special node for this character */
+ op = (ASCII_FOLD_RESTRICTED)
+ ? EXACTFAA
+ : EXACTFUP;
+ value = MICRO_SIGN;
+ }
+ else if ( ASCII_FOLD_RESTRICTED
+ && ! isASCII(lowest_cp))
+ { /* For ASCII under /iaa, we can use EXACTFU below
+ */
+ op = EXACTFAA;
+ value = folded;
+ }
+ else {
+ op = EXACTFU;
+ value = folded;
}
}
-
- SvREFCNT_dec_NN(fold_list);
- SvREFCNT_dec(all_cp_list);
}
- }
- if (op != END) {
- U8 len;
+ SvREFCNT_dec_NN(fold_list);
+ SvREFCNT_dec(all_cp_list);
+ }
+ }
- /* Here, we have calculated what EXACTish node to use. Have to
- * convert to UTF-8 if not already there */
- if (value > 255) {
- if (! UTF) {
- SvREFCNT_dec(cp_list);;
- REQUIRE_UTF8(flagp);
- }
+ if (op != END) {
+ U8 len;
- /* This is a kludge to the special casing issues with this
- * ligature under /aa. FB05 should fold to FB06, but the
- * call above to _to_uni_fold_flags() didn't find this, as
- * it didn't use the /aa restriction in order to not miss
- * other folds that would be affected. This is the only
- * instance likely to ever be a problem in all of Unicode.
- * So special case it. */
- if ( value == LATIN_SMALL_LIGATURE_LONG_S_T
- && ASCII_FOLD_RESTRICTED)
- {
- value = LATIN_SMALL_LIGATURE_ST;
- }
+ /* Here, we have calculated what EXACTish node to use. Have to
+ * convert to UTF-8 if not already there */
+ if (value > 255) {
+ if (! UTF) {
+ SvREFCNT_dec(cp_list);;
+ REQUIRE_UTF8(flagp);
}
- len = (UTF) ? UVCHR_SKIP(value) : 1;
-
- ret = regnode_guts(pRExC_state, op, len, "exact");
- FILL_NODE(ret, op);
- RExC_emit += 1 + STR_SZ(len);
- setSTR_LEN(REGNODE_p(ret), len);
- if (len == 1) {
- *STRINGs(REGNODE_p(ret)) = (U8) value;
+ /* This is a kludge to the special casing issues with this
+ * ligature under /aa. FB05 should fold to FB06, but the call
+ * above to _to_uni_fold_flags() didn't find this, as it didn't
+ * use the /aa restriction in order to not miss other folds
+ * that would be affected. This is the only instance likely to
+ * ever be a problem in all of Unicode. So special case it. */
+ if ( value == LATIN_SMALL_LIGATURE_LONG_S_T
+ && ASCII_FOLD_RESTRICTED)
+ {
+ value = LATIN_SMALL_LIGATURE_ST;
}
- else {
- uvchr_to_utf8((U8 *) STRINGs(REGNODE_p(ret)), value);
- }
- goto not_anyof;
- }
- }
-
- if (! has_runtime_dependency) {
-
- /* See if this can be turned into an ANYOFM node. Think about the
- * bit patterns in two different bytes. In some positions, the
- * bits in each will be 1; and in other positions both will be 0;
- * and in some positions the bit will be 1 in one byte, and 0 in
- * the other. Let 'n' be the number of positions where the bits
- * differ. We create a mask which has exactly 'n' 0 bits, each in
- * a position where the two bytes differ. Now take the set of all
- * bytes that when ANDed with the mask yield the same result. That
- * set has 2**n elements, and is representable by just two 8 bit
- * numbers: the result and the mask. Importantly, matching the set
- * can be vectorized by creating a word full of the result bytes,
- * and a word full of the mask bytes, yielding a significant speed
- * up. Here, see if this node matches such a set. As a concrete
- * example consider [01], and the byte representing '0' which is
- * 0x30 on ASCII machines. It has the bits 0011 0000. Take the
- * mask 1111 1110. If we AND 0x31 and 0x30 with that mask we get
- * 0x30. Any other bytes ANDed yield something else. So [01],
- * which is a common usage, is optimizable into ANYOFM, and can
- * benefit from the speed up. We can only do this on UTF-8
- * invariant bytes, because they have the same bit patterns under
- * UTF-8 as not. */
- PERL_UINT_FAST8_T inverted = 0;
-#ifdef EBCDIC
- const PERL_UINT_FAST8_T max_permissible = 0xFF;
-#else
- const PERL_UINT_FAST8_T max_permissible = 0x7F;
-#endif
- /* If doesn't fit the criteria for ANYOFM, invert and try again.
- * If that works we will instead later generate an NANYOFM, and
- * invert back when through */
- if (invlist_highest(cp_list) > max_permissible) {
- _invlist_invert(cp_list);
- inverted = 1;
- }
-
- if (invlist_highest(cp_list) <= max_permissible) {
- UV this_start, this_end;
- UV lowest_cp = UV_MAX; /* init'ed to suppress compiler warn */
- U8 bits_differing = 0;
- Size_t full_cp_count = 0;
- bool first_time = TRUE;
-
- /* Go through the bytes and find the bit positions that differ
- * */
- invlist_iterinit(cp_list);
- while (invlist_iternext(cp_list, &this_start, &this_end)) {
- unsigned int i = this_start;
+ }
- if (first_time) {
- if (! UVCHR_IS_INVARIANT(i)) {
- goto done_anyofm;
- }
+ len = (UTF) ? UVCHR_SKIP(value) : 1;
- first_time = FALSE;
- lowest_cp = this_start;
+ *ret = REGNODE_GUTS(pRExC_state, op, len);
+ FILL_NODE(*ret, op);
+ RExC_emit += NODE_STEP_REGNODE + STR_SZ(len);
+ setSTR_LEN(REGNODE_p(*ret), len);
+ if (len == 1) {
+ *STRINGs(REGNODE_p(*ret)) = (U8) value;
+ }
+ else {
+ uvchr_to_utf8((U8 *) STRINGs(REGNODE_p(*ret)), value);
+ }
+
+ return op;
+ }
+ }
+
+ if (! has_runtime_dependency) {
+
+ /* See if this can be turned into an ANYOFM node. Think about the bit
+ * patterns in two different bytes. In some positions, the bits in
+ * each will be 1; and in other positions both will be 0; and in some
+ * positions the bit will be 1 in one byte, and 0 in the other. Let
+ * 'n' be the number of positions where the bits differ. We create a
+ * mask which has exactly 'n' 0 bits, each in a position where the two
+ * bytes differ. Now take the set of all bytes that when ANDed with
+ * the mask yield the same result. That set has 2**n elements, and is
+ * representable by just two 8 bit numbers: the result and the mask.
+ * Importantly, matching the set can be vectorized by creating a word
+ * full of the result bytes, and a word full of the mask bytes,
+ * yielding a significant speed up. Here, see if this node matches
+ * such a set. As a concrete example consider [01], and the byte
+ * representing '0' which is 0x30 on ASCII machines. It has the bits
+ * 0011 0000. Take the mask 1111 1110. If we AND 0x31 and 0x30 with
+ * that mask we get 0x30. Any other bytes ANDed yield something else.
+ * So [01], which is a common usage, is optimizable into ANYOFM, and
+ * can benefit from the speed up. We can only do this on UTF-8
+ * invariant bytes, because they have the same bit patterns under UTF-8
+ * as not. */
+ PERL_UINT_FAST8_T inverted = 0;
+
+ /* Highest possible UTF-8 invariant is 7F on ASCII platforms; FF on
+ * EBCDIC */
+ const PERL_UINT_FAST8_T max_permissible
+ = nBIT_UMAX(7 + ONE_IF_EBCDIC_ZERO_IF_NOT);
+
+ /* If doesn't fit the criteria for ANYOFM, invert and try again. If
+ * that works we will instead later generate an NANYOFM, and invert
+ * back when through */
+ if (highest_cp > max_permissible) {
+ _invlist_invert(cp_list);
+ inverted = 1;
+ }
- /* We have set up the code point to compare with.
- * Don't compare it with itself */
- i++;
- }
+ if (invlist_highest(cp_list) <= max_permissible) {
+ UV this_start, this_end;
+ UV lowest_cp = UV_MAX; /* init'ed to suppress compiler warn */
+ U8 bits_differing = 0;
+ Size_t full_cp_count = 0;
+ bool first_time = TRUE;
- /* Find the bit positions that differ from the lowest code
- * point in the node. Keep track of all such positions by
- * OR'ing */
- for (; i <= this_end; i++) {
- if (! UVCHR_IS_INVARIANT(i)) {
- goto done_anyofm;
- }
+ /* Go through the bytes and find the bit positions that differ */
+ invlist_iterinit(cp_list);
+ while (invlist_iternext(cp_list, &this_start, &this_end)) {
+ unsigned int i = this_start;
- bits_differing |= i ^ lowest_cp;
+ if (first_time) {
+ if (! UVCHR_IS_INVARIANT(i)) {
+ goto done_anyofm;
}
- full_cp_count += this_end - this_start + 1;
- }
-
- /* At the end of the loop, we count how many bits differ from
- * the bits in lowest code point, call the count 'd'. If the
- * set we found contains 2**d elements, it is the closure of
- * all code points that differ only in those bit positions. To
- * convince yourself of that, first note that the number in the
- * closure must be a power of 2, which we test for. The only
- * way we could have that count and it be some differing set,
- * is if we got some code points that don't differ from the
- * lowest code point in any position, but do differ from each
- * other in some other position. That means one code point has
- * a 1 in that position, and another has a 0. But that would
- * mean that one of them differs from the lowest code point in
- * that position, which possibility we've already excluded. */
- if ( (inverted || full_cp_count > 1)
- && full_cp_count == 1U << PL_bitcount[bits_differing])
- {
- U8 ANYOFM_mask;
+ first_time = FALSE;
+ lowest_cp = this_start;
- op = ANYOFM + inverted;;
+ /* We have set up the code point to compare with. Don't
+ * compare it with itself */
+ i++;
+ }
- /* We need to make the bits that differ be 0's */
- ANYOFM_mask = ~ bits_differing; /* This goes into FLAGS */
+ /* Find the bit positions that differ from the lowest code
+ * point in the node. Keep track of all such positions by
+ * OR'ing */
+ for (; i <= this_end; i++) {
+ if (! UVCHR_IS_INVARIANT(i)) {
+ goto done_anyofm;
+ }
- /* The argument is the lowest code point */
- ret = reganode(pRExC_state, op, lowest_cp);
- FLAGS(REGNODE_p(ret)) = ANYOFM_mask;
+ bits_differing |= i ^ lowest_cp;
}
- done_anyofm:
- invlist_iterfinish(cp_list);
+ full_cp_count += this_end - this_start + 1;
}
- if (inverted) {
- _invlist_invert(cp_list);
- }
+ /* At the end of the loop, we count how many bits differ from the
+ * bits in lowest code point, call the count 'd'. If the set we
+ * found contains 2**d elements, it is the closure of all code
+ * points that differ only in those bit positions. To convince
+ * yourself of that, first note that the number in the closure must
+ * be a power of 2, which we test for. The only way we could have
+ * that count and it be some differing set, is if we got some code
+ * points that don't differ from the lowest code point in any
+ * position, but do differ from each other in some other position.
+ * That means one code point has a 1 in that position, and another
+ * has a 0. But that would mean that one of them differs from the
+ * lowest code point in that position, which possibility we've
+ * already excluded. */
+ if ( (inverted || full_cp_count > 1)
+ && full_cp_count == 1U << PL_bitcount[bits_differing])
+ {
+ U8 ANYOFM_mask;
- if (op != END) {
- goto not_anyof;
+ op = ANYOFM + inverted;;
+
+ /* We need to make the bits that differ be 0's */
+ ANYOFM_mask = ~ bits_differing; /* This goes into FLAGS */
+
+ /* The argument is the lowest code point */
+ *ret = reg1node(pRExC_state, op, lowest_cp);
+ FLAGS(REGNODE_p(*ret)) = ANYOFM_mask;
}
- /* XXX We could create an ANYOFR_LOW node here if we saved above if
- * all were invariants, it wasn't inverted, and there is a single
- * range. This would be faster than some of the posix nodes we
- * create below like /\d/a, but would be twice the size. Without
- * having actually measured the gain, khw doesn't think the
- * tradeoff is really worth it */
+ done_anyofm:
+ invlist_iterfinish(cp_list);
}
- if (! (anyof_flags & ANYOF_LOCALE_FLAGS)) {
- PERL_UINT_FAST8_T type;
- SV * intersection = NULL;
- SV* d_invlist = NULL;
+ if (inverted) {
+ _invlist_invert(cp_list);
+ }
- /* See if this matches any of the POSIX classes. The POSIXA and
- * POSIXD ones are about the same speed as ANYOF ops, but take less
- * room; the ones that have above-Latin1 code point matches are
- * somewhat faster than ANYOF. */
+ if (op != END) {
+ return op;
+ }
- for (type = POSIXA; type >= POSIXD; type--) {
- int posix_class;
+ /* XXX We could create an ANYOFR_LOW node here if we saved above if all
+ * were invariants, it wasn't inverted, and there is a single range.
+ * This would be faster than some of the posix nodes we create below
+ * like /\d/a, but would be twice the size. Without having actually
+ * measured the gain, khw doesn't think the tradeoff is really worth it
+ * */
+ }
- if (type == POSIXL) { /* But not /l posix classes */
- continue;
- }
+ if (! (*anyof_flags & ANYOF_LOCALE_FLAGS)) {
+ PERL_UINT_FAST8_T type;
+ SV * intersection = NULL;
+ SV* d_invlist = NULL;
- for (posix_class = 0;
- posix_class <= _HIGHEST_REGCOMP_DOT_H_SYNC;
- posix_class++)
- {
- SV** our_code_points = &cp_list;
- SV** official_code_points;
- int try_inverted;
+ /* See if this matches any of the POSIX classes. The POSIXA and POSIXD
+ * ones are about the same speed as ANYOF ops, but take less room; the
+ * ones that have above-Latin1 code point matches are somewhat faster
+ * than ANYOF. */
- if (type == POSIXA) {
- official_code_points = &PL_Posix_ptrs[posix_class];
- }
- else {
- official_code_points = &PL_XPosix_ptrs[posix_class];
- }
+ for (type = POSIXA; type >= POSIXD; type--) {
+ int posix_class;
- /* Skip non-existent classes of this type. e.g. \v only
- * has an entry in PL_XPosix_ptrs */
- if (! *official_code_points) {
- continue;
- }
+ if (type == POSIXL) { /* But not /l posix classes */
+ continue;
+ }
- /* Try both the regular class, and its inversion */
- for (try_inverted = 0; try_inverted < 2; try_inverted++) {
- bool this_inverted = invert ^ try_inverted;
+ for (posix_class = 0;
+ posix_class <= HIGHEST_REGCOMP_DOT_H_SYNC_;
+ posix_class++)
+ {
+ SV** our_code_points = &cp_list;
+ SV** official_code_points;
+ int try_inverted;
- if (type != POSIXD) {
+ if (type == POSIXA) {
+ official_code_points = &PL_Posix_ptrs[posix_class];
+ }
+ else {
+ official_code_points = &PL_XPosix_ptrs[posix_class];
+ }
- /* This class that isn't /d can't match if we have
- * /d dependencies */
- if (has_runtime_dependency
- & HAS_D_RUNTIME_DEPENDENCY)
- {
- continue;
- }
- }
- else /* is /d */ if (! this_inverted) {
-
- /* /d classes don't match anything non-ASCII below
- * 256 unconditionally (which cp_list contains) */
- _invlist_intersection(cp_list, PL_UpperLatin1,
- &intersection);
- if (_invlist_len(intersection) != 0) {
- continue;
- }
+ /* Skip non-existent classes of this type. e.g. \v only has an
+ * entry in PL_XPosix_ptrs */
+ if (! *official_code_points) {
+ continue;
+ }
- SvREFCNT_dec(d_invlist);
- d_invlist = invlist_clone(cp_list, NULL);
+ /* Try both the regular class, and its inversion */
+ for (try_inverted = 0; try_inverted < 2; try_inverted++) {
+ bool this_inverted = *invert ^ try_inverted;
- /* But under UTF-8 it turns into using /u rules.
- * Add the things it matches under these conditions
- * so that we check below that these are identical
- * to what the tested class should match */
- if (upper_latin1_only_utf8_matches) {
- _invlist_union(
- d_invlist,
- upper_latin1_only_utf8_matches,
- &d_invlist);
- }
- our_code_points = &d_invlist;
+ if (type != POSIXD) {
+
+ /* This class that isn't /d can't match if we have /d
+ * dependencies */
+ if (has_runtime_dependency
+ & HAS_D_RUNTIME_DEPENDENCY)
+ {
+ continue;
}
- else { /* POSIXD, inverted. If this doesn't have this
- flag set, it isn't /d. */
- if (! (anyof_flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER))
- {
- continue;
- }
- our_code_points = &cp_list;
+ }
+ else /* is /d */ if (! this_inverted) {
+
+ /* /d classes don't match anything non-ASCII below 256
+ * unconditionally (which cp_list contains) */
+ _invlist_intersection(cp_list, PL_UpperLatin1,
+ &intersection);
+ if (_invlist_len(intersection) != 0) {
+ continue;
}
- /* Here, have weeded out some things. We want to see
- * if the list of characters this node contains
- * ('*our_code_points') precisely matches those of the
- * class we are currently checking against
- * ('*official_code_points'). */
- if (_invlistEQ(*our_code_points,
- *official_code_points,
- try_inverted))
+ SvREFCNT_dec(d_invlist);
+ d_invlist = invlist_clone(cp_list, NULL);
+
+ /* But under UTF-8 it turns into using /u rules. Add
+ * the things it matches under these conditions so that
+ * we check below that these are identical to what the
+ * tested class should match */
+ if (upper_latin1_only_utf8_matches) {
+ _invlist_union(
+ d_invlist,
+ upper_latin1_only_utf8_matches,
+ &d_invlist);
+ }
+ our_code_points = &d_invlist;
+ }
+ else { /* POSIXD, inverted. If this doesn't have this
+ flag set, it isn't /d. */
+ if (! ( *anyof_flags
+ & ANYOFD_NON_UTF8_MATCHES_ALL_NON_ASCII__shared))
{
- /* Here, they precisely match. Optimize this ANYOF
- * node into its equivalent POSIX one of the
- * correct type, possibly inverted */
- ret = reg_node(pRExC_state, (try_inverted)
- ? type + NPOSIXA
- - POSIXA
- : type);
- FLAGS(REGNODE_p(ret)) = posix_class;
- SvREFCNT_dec(d_invlist);
- SvREFCNT_dec(intersection);
- goto not_anyof;
+ continue;
}
+
+ our_code_points = &cp_list;
}
- }
- }
- SvREFCNT_dec(d_invlist);
- SvREFCNT_dec(intersection);
- }
- /* If it is a single contiguous range, ANYOFR is an efficient regnode,
- * both in size and speed. Currently, a 20 bit range base (smallest
- * code point in the range), and a 12 bit maximum delta are packed into
- * a 32 bit word. This allows for using it on all of the Unicode code
- * points except for the highest plane, which is only for private use
- * code points. khw doubts that a bigger delta is likely in real world
- * applications */
- if ( single_range
- && ! has_runtime_dependency
- && anyof_flags == 0
- && start[0] < (1 << ANYOFR_BASE_BITS)
- && end[0] - start[0]
- < ((1U << (sizeof(((struct regnode_1 *)NULL)->arg1)
- * CHARBITS - ANYOFR_BASE_BITS))))
+ /* Here, have weeded out some things. We want to see if
+ * the list of characters this node contains
+ * ('*our_code_points') precisely matches those of the
+ * class we are currently checking against
+ * ('*official_code_points'). */
+ if (_invlistEQ(*our_code_points,
+ *official_code_points,
+ try_inverted))
+ {
+ /* Here, they precisely match. Optimize this ANYOF
+ * node into its equivalent POSIX one of the correct
+ * type, possibly inverted.
+ *
+ * Some of these nodes match a single range of
+ * characters (or [:alpha:] matches two parallel ranges
+ * on ASCII platforms). The array lookup at execution
+ * time could be replaced by a range check for such
+ * nodes. But regnodes are a finite resource, and the
+ * possible performance boost isn't large, so this
+ * hasn't been done. An attempt to use just one node
+ * (and its inverse) to encompass all such cases was
+ * made in d62feba66bf43f35d092bb026694f927e9f94d38.
+ * But the shifting/masking it used ended up being
+ * slower than the array look up, so it was reverted */
+ op = (try_inverted)
+ ? type + NPOSIXA - POSIXA
+ : type;
+ *ret = reg_node(pRExC_state, op);
+ FLAGS(REGNODE_p(*ret)) = posix_class;
+ SvREFCNT_dec(d_invlist);
+ SvREFCNT_dec(intersection);
+ return op;
+ }
+ }
+ }
+ }
+ SvREFCNT_dec(d_invlist);
+ SvREFCNT_dec(intersection);
+ }
+
+ /* If it is a single contiguous range, ANYOFR is an efficient regnode, both
+ * in size and speed. Currently, a 20 bit range base (smallest code point
+ * in the range), and a 12 bit maximum delta are packed into a 32 bit word.
+ * This allows for using it on all of the Unicode code points except for
+ * the highest plane, which is only for private use code points. khw
+ * doubts that a bigger delta is likely in real world applications */
+ if ( single_range
+ && ! has_runtime_dependency
+ && *anyof_flags == 0
+ && start[0] < (1 << ANYOFR_BASE_BITS)
+ && end[0] - start[0]
+ < ((1U << (sizeof(ARG1u_LOC(NULL))
+ * CHARBITS - ANYOFR_BASE_BITS))))
- {
- U8 low_utf8[UTF8_MAXBYTES+1];
- U8 high_utf8[UTF8_MAXBYTES+1];
+ {
+ U8 low_utf8[UTF8_MAXBYTES+1];
+ U8 high_utf8[UTF8_MAXBYTES+1];
- ret = reganode(pRExC_state, ANYOFR,
+ op = ANYOFR;
+ *ret = reg1node(pRExC_state, op,
(start[0] | (end[0] - start[0]) << ANYOFR_BASE_BITS));
- /* Place the lowest UTF-8 start byte in the flags field, so as to
- * allow efficient ruling out at run time of many possible inputs.
- * */
- (void) uvchr_to_utf8(low_utf8, start[0]);
- (void) uvchr_to_utf8(high_utf8, end[0]);
-
- /* If all code points share the same first byte, this can be an
- * ANYOFRb. Otherwise store the lowest UTF-8 start byte which can
- * quickly rule out many inputs at run-time without having to
- * compute the code point from UTF-8. For EBCDIC, we use I8, as
- * not doing that transformation would not rule out nearly so many
- * things */
+ /* Place the lowest UTF-8 start byte in the flags field, so as to allow
+ * efficient ruling out at run time of many possible inputs. */
+ (void) uvchr_to_utf8(low_utf8, start[0]);
+ (void) uvchr_to_utf8(high_utf8, end[0]);
+
+ /* If all code points share the same first byte, this can be an
+ * ANYOFRb. Otherwise store the lowest UTF-8 start byte which can
+ * quickly rule out many inputs at run-time without having to compute
+ * the code point from UTF-8. For EBCDIC, we use I8, as not doing that
+ * transformation would not rule out nearly so many things */
+ if (low_utf8[0] == high_utf8[0]) {
+ op = ANYOFRb;
+ OP(REGNODE_p(*ret)) = op;
+ ANYOF_FLAGS(REGNODE_p(*ret)) = low_utf8[0];
+ }
+ else {
+ ANYOF_FLAGS(REGNODE_p(*ret)) = NATIVE_UTF8_TO_I8(low_utf8[0]);
+ }
+
+ return op;
+ }
+
+ /* If didn't find an optimization and there is no need for a bitmap,
+ * of the lowest code points, optimize to indicate that */
+ if ( lowest_cp >= NUM_ANYOF_CODE_POINTS
+ && ! LOC
+ && ! upper_latin1_only_utf8_matches
+ && *anyof_flags == 0)
+ {
+ U8 low_utf8[UTF8_MAXBYTES+1];
+ UV highest_cp = invlist_highest(cp_list);
+
+ /* Currently the maximum allowed code point by the system is IV_MAX.
+ * Higher ones are reserved for future internal use. This particular
+ * regnode can be used for higher ones, but we can't calculate the code
+ * point of those. IV_MAX suffices though, as it will be a large first
+ * byte */
+ Size_t low_len = uvchr_to_utf8(low_utf8, MIN(lowest_cp, IV_MAX))
+ - low_utf8;
+
+ /* We store the lowest possible first byte of the UTF-8 representation,
+ * using the flags field. This allows for quick ruling out of some
+ * inputs without having to convert from UTF-8 to code point. For
+ * EBCDIC, we use I8, as not doing that transformation would not rule
+ * out nearly so many things */
+ *anyof_flags = NATIVE_UTF8_TO_I8(low_utf8[0]);
+
+ op = ANYOFH;
+
+ /* If the first UTF-8 start byte for the highest code point in the
+ * range is suitably small, we may be able to get an upper bound as
+ * well */
+ if (highest_cp <= IV_MAX) {
+ U8 high_utf8[UTF8_MAXBYTES+1];
+ Size_t high_len = uvchr_to_utf8(high_utf8, highest_cp) - high_utf8;
+
+ /* If the lowest and highest are the same, we can get an exact
+ * first byte instead of a just minimum or even a sequence of exact
+ * leading bytes. We signal these with different regnodes */
if (low_utf8[0] == high_utf8[0]) {
- OP(REGNODE_p(ret)) = ANYOFRb;
- ANYOF_FLAGS(REGNODE_p(ret)) = low_utf8[0];
- }
- else {
- ANYOF_FLAGS(REGNODE_p(ret))
- = NATIVE_UTF8_TO_I8(low_utf8[0]);
- }
+ Size_t len = find_first_differing_byte_pos(low_utf8,
+ high_utf8,
+ MIN(low_len, high_len));
+ if (len == 1) {
- goto not_anyof;
- }
+ /* No need to convert to I8 for EBCDIC as this is an exact
+ * match */
+ *anyof_flags = low_utf8[0];
- /* If didn't find an optimization and there is no need for a bitmap,
- * optimize to indicate that */
- if ( start[0] >= NUM_ANYOF_CODE_POINTS
- && ! LOC
- && ! upper_latin1_only_utf8_matches
- && anyof_flags == 0)
- {
- U8 low_utf8[UTF8_MAXBYTES+1];
- UV highest_cp = invlist_highest(cp_list);
-
- /* Currently the maximum allowed code point by the system is
- * IV_MAX. Higher ones are reserved for future internal use. This
- * particular regnode can be used for higher ones, but we can't
- * calculate the code point of those. IV_MAX suffices though, as
- * it will be a large first byte */
- Size_t low_len = uvchr_to_utf8(low_utf8, MIN(start[0], IV_MAX))
- - low_utf8;
-
- /* We store the lowest possible first byte of the UTF-8
- * representation, using the flags field. This allows for quick
- * ruling out of some inputs without having to convert from UTF-8
- * to code point. For EBCDIC, we use I8, as not doing that
- * transformation would not rule out nearly so many things */
- anyof_flags = NATIVE_UTF8_TO_I8(low_utf8[0]);
-
- op = ANYOFH;
-
- /* If the first UTF-8 start byte for the highest code point in the
- * range is suitably small, we may be able to get an upper bound as
- * well */
- if (highest_cp <= IV_MAX) {
- U8 high_utf8[UTF8_MAXBYTES+1];
- Size_t high_len = uvchr_to_utf8(high_utf8, highest_cp)
- - high_utf8;
-
- /* If the lowest and highest are the same, we can get an exact
- * first byte instead of a just minimum or even a sequence of
- * exact leading bytes. We signal these with different
- * regnodes */
- if (low_utf8[0] == high_utf8[0]) {
- Size_t len = find_first_differing_byte_pos(low_utf8,
- high_utf8,
- MIN(low_len, high_len));
-
- if (len == 1) {
-
- /* No need to convert to I8 for EBCDIC as this is an
- * exact match */
- anyof_flags = low_utf8[0];
- op = ANYOFHb;
+ if (high_len == 2) {
+ /* If the elements matched all have a 2-byte UTF-8
+ * representation, with the first byte being the same,
+ * we can use a compact, fast regnode. capable of
+ * matching any combination of continuation byte
+ * patterns.
+ *
+ * (A similar regnode could be created for the Latin1
+ * range; the complication being that it could match
+ * non-UTF8 targets. The internal bitmap would serve
+ * both cases; with some extra code in regexec.c) */
+ op = ANYOFHbbm;
+ *ret = REGNODE_GUTS(pRExC_state, op, REGNODE_ARG_LEN(op));
+ FILL_NODE(*ret, op);
+ FIRST_BYTE((struct regnode_bbm *) REGNODE_p(*ret)) = low_utf8[0],
+
+ /* The 64 bit (or 32 on EBCCDIC) map can be looked up
+ * directly based on the continuation byte, without
+ * needing to convert to code point */
+ populate_bitmap_from_invlist(
+ cp_list,
+
+ /* The base code point is from the start byte */
+ TWO_BYTE_UTF8_TO_NATIVE(low_utf8[0],
+ UTF_CONTINUATION_MARK | 0),
+
+ ((struct regnode_bbm *) REGNODE_p(*ret))->bitmap,
+ REGNODE_BBM_BITMAP_LEN);
+ RExC_emit += NODE_STEP_REGNODE + REGNODE_ARG_LEN(op);
+ return op;
}
else {
- op = ANYOFHs;
- ret = regnode_guts(pRExC_state, op,
- regarglen[op] + STR_SZ(len),
- "anyofhs");
- FILL_NODE(ret, op);
- ((struct regnode_anyofhs *) REGNODE_p(ret))->str_len
- = len;
- Copy(low_utf8, /* Add the common bytes */
- ((struct regnode_anyofhs *) REGNODE_p(ret))->string,
- len, U8);
- RExC_emit += NODE_SZ_STR(REGNODE_p(ret));
- set_ANYOF_arg(pRExC_state, REGNODE_p(ret), cp_list,
- NULL, only_utf8_locale_list);
- goto not_anyof;
+ op = ANYOFHb;
}
}
- else if (NATIVE_UTF8_TO_I8(high_utf8[0]) <= MAX_ANYOF_HRx_BYTE)
- {
+ else {
+ op = ANYOFHs;
+ *ret = REGNODE_GUTS(pRExC_state, op,
+ REGNODE_ARG_LEN(op) + STR_SZ(len));
+ FILL_NODE(*ret, op);
+ STR_LEN_U8((struct regnode_anyofhs *) REGNODE_p(*ret))
+ = len;
+ Copy(low_utf8, /* Add the common bytes */
+ ((struct regnode_anyofhs *) REGNODE_p(*ret))->string,
+ len, U8);
+ RExC_emit = REGNODE_OFFSET(REGNODE_AFTER_varies(REGNODE_p(*ret)));
+ set_ANYOF_arg(pRExC_state, REGNODE_p(*ret), cp_list,
+ NULL, only_utf8_locale_list);
+ return op;
+ }
+ }
+ else if (NATIVE_UTF8_TO_I8(high_utf8[0]) <= MAX_ANYOF_HRx_BYTE) {
- /* Here, the high byte is not the same as the low, but is
- * small enough that its reasonable to have a loose upper
- * bound, which is packed in with the strict lower bound.
- * See comments at the definition of MAX_ANYOF_HRx_BYTE.
- * On EBCDIC platforms, I8 is used. On ASCII platforms I8
- * is the same thing as UTF-8 */
+ /* Here, the high byte is not the same as the low, but is small
+ * enough that its reasonable to have a loose upper bound,
+ * which is packed in with the strict lower bound. See
+ * comments at the definition of MAX_ANYOF_HRx_BYTE. On EBCDIC
+ * platforms, I8 is used. On ASCII platforms I8 is the same
+ * thing as UTF-8 */
- U8 bits = 0;
- U8 max_range_diff = MAX_ANYOF_HRx_BYTE - anyof_flags;
- U8 range_diff = NATIVE_UTF8_TO_I8(high_utf8[0])
- - anyof_flags;
+ U8 bits = 0;
+ U8 max_range_diff = MAX_ANYOF_HRx_BYTE - *anyof_flags;
+ U8 range_diff = NATIVE_UTF8_TO_I8(high_utf8[0])
+ - *anyof_flags;
- if (range_diff <= max_range_diff / 8) {
- bits = 3;
- }
- else if (range_diff <= max_range_diff / 4) {
- bits = 2;
- }
- else if (range_diff <= max_range_diff / 2) {
- bits = 1;
- }
- anyof_flags = (anyof_flags - 0xC0) << 2 | bits;
- op = ANYOFHr;
+ if (range_diff <= max_range_diff / 8) {
+ bits = 3;
}
+ else if (range_diff <= max_range_diff / 4) {
+ bits = 2;
+ }
+ else if (range_diff <= max_range_diff / 2) {
+ bits = 1;
+ }
+ *anyof_flags = (*anyof_flags - 0xC0) << 2 | bits;
+ op = ANYOFHr;
}
-
- goto done_finding_op;
}
- } /* End of seeing if can optimize it into a different node */
-
- is_anyof: /* It's going to be an ANYOF node. */
- op = (has_runtime_dependency & HAS_D_RUNTIME_DEPENDENCY)
- ? ANYOFD
- : ((posixl)
- ? ANYOFPOSIXL
- : ((LOC)
- ? ANYOFL
- : ANYOF));
-
- done_finding_op:
-
- ret = regnode_guts(pRExC_state, op, regarglen[op], "anyof");
- FILL_NODE(ret, op); /* We set the argument later */
- RExC_emit += 1 + regarglen[op];
- ANYOF_FLAGS(REGNODE_p(ret)) = anyof_flags;
-
- /* Here, <cp_list> contains all the code points we can determine at
- * compile time that match under all conditions. Go through it, and
- * for things that belong in the bitmap, put them there, and delete from
- * <cp_list>. While we are at it, see if everything above 255 is in the
- * list, and if so, set a flag to speed up execution */
-
- populate_ANYOF_from_invlist(REGNODE_p(ret), &cp_list);
-
- if (posixl) {
- ANYOF_POSIXL_SET_TO_BITMAP(REGNODE_p(ret), posixl);
- }
-
- if (invert) {
- ANYOF_FLAGS(REGNODE_p(ret)) |= ANYOF_INVERT;
- }
-
- /* Here, the bitmap has been populated with all the Latin1 code points that
- * always match. Can now add to the overall list those that match only
- * when the target string is UTF-8 (<upper_latin1_only_utf8_matches>).
- * */
- if (upper_latin1_only_utf8_matches) {
- if (cp_list) {
- _invlist_union(cp_list,
- upper_latin1_only_utf8_matches,
- &cp_list);
- SvREFCNT_dec_NN(upper_latin1_only_utf8_matches);
- }
- else {
- cp_list = upper_latin1_only_utf8_matches;
- }
- ANYOF_FLAGS(REGNODE_p(ret)) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
}
- set_ANYOF_arg(pRExC_state, REGNODE_p(ret), cp_list,
- (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
- ? listsv
- : NULL,
- only_utf8_locale_list);
- SvREFCNT_dec(cp_list);;
- SvREFCNT_dec(only_utf8_locale_list);
- return ret;
-
- not_anyof:
+ return op;
- /* Here, the node is getting optimized into something that's not an ANYOF
- * one. Finish up. */
+ return_OPFAIL:
+ op = OPFAIL;
+ *ret = reg1node(pRExC_state, op, 0);
+ return op;
- Set_Node_Offset_Length(REGNODE_p(ret), orig_parse - RExC_start,
- RExC_parse - orig_parse);;
- SvREFCNT_dec(cp_list);;
- SvREFCNT_dec(only_utf8_locale_list);
- return ret;
+ return_SANY:
+ op = SANY;
+ *ret = reg_node(pRExC_state, op);
+ MARK_NAUGHTY(1);
+ return op;
}
#undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
-STATIC void
-S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state,
+#ifdef PERL_RE_BUILD_AUX
+void
+Perl_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state,
regnode* const node,
SV* const cp_list,
SV* const runtime_defns,
SV* const only_utf8_locale_list)
{
/* Sets the arg field of an ANYOF-type node 'node', using information about
- * the node passed-in. If there is nothing outside the node's bitmap, the
- * arg is set to ANYOF_ONLY_HAS_BITMAP. Otherwise, it sets the argument to
- * the count returned by add_data(), having allocated and stored an array,
- * av, as follows:
+ * the node passed-in. If only the bitmap is needed to determine what
+ * matches, the arg is set appropriately to either
+ * 1) ANYOF_MATCHES_NONE_OUTSIDE_BITMAP_VALUE
+ * 2) ANYOF_MATCHES_ALL_OUTSIDE_BITMAP_VALUE
*
+ * Otherwise, it sets the argument to the count returned by reg_add_data(),
+ * having allocated and stored an array, av, as follows:
* av[0] stores the inversion list defining this class as far as known at
* this time, or PL_sv_undef if nothing definite is now known.
* av[1] stores the inversion list of code points that match only if the
PERL_ARGS_ASSERT_SET_ANYOF_ARG;
- if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) {
- assert(! (ANYOF_FLAGS(node)
- & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP));
- ARG_SET(node, ANYOF_ONLY_HAS_BITMAP);
+ /* If this is set, the final disposition won't be known until runtime, so
+ * we can't do any of the compile time optimizations */
+ if (! runtime_defns) {
+
+ /* On plain ANYOF nodes without the possibility of a runtime locale
+ * making a difference, maybe there's no information to be gleaned
+ * except for what's in the bitmap */
+ if (REGNODE_TYPE(OP(node)) == ANYOF && ! only_utf8_locale_list) {
+
+ /* There are two such cases:
+ * 1) there is no list of code points matched outside the bitmap
+ */
+ if (! cp_list) {
+ ARG1u_SET(node, ANYOF_MATCHES_NONE_OUTSIDE_BITMAP_VALUE);
+ return;
+ }
+
+ /* 2) the list indicates everything outside the bitmap matches */
+ if ( invlist_highest(cp_list) == UV_MAX
+ && invlist_highest_range_start(cp_list)
+ <= NUM_ANYOF_CODE_POINTS)
+ {
+ ARG1u_SET(node, ANYOF_MATCHES_ALL_OUTSIDE_BITMAP_VALUE);
+ return;
+ }
+
+ /* In all other cases there are things outside the bitmap that we
+ * may need to check at runtime. */
+ }
+
+ /* Here, we have resolved all the possible run-time matches, and they
+ * are stored in one or both of two possible lists. (While some match
+ * only under certain runtime circumstances, we know all the possible
+ * ones for each such circumstance.)
+ *
+ * It may very well be that the pattern being compiled contains an
+ * identical class, already encountered. Reusing that class here saves
+ * space. Look through all classes so far encountered. */
+ U32 existing_items = RExC_rxi->data ? RExC_rxi->data->count : 0;
+ for (unsigned int i = 0; i < existing_items; i++) {
+
+ /* Only look at auxiliary data of this type */
+ if (RExC_rxi->data->what[i] != 's') {
+ continue;
+ }
+
+ SV * const rv = MUTABLE_SV(RExC_rxi->data->data[i]);
+ AV * const av = MUTABLE_AV(SvRV(rv));
+
+ /* If the already encountered class has data that won't be known
+ * until runtime (stored in the final element of the array), we
+ * can't share */
+ if (av_top_index(av) > ONLY_LOCALE_MATCHES_INDEX) {
+ continue;
+ }
+
+ SV ** stored_cp_list_ptr = av_fetch(av, INVLIST_INDEX,
+ false /* no lvalue */);
+
+ /* The new and the existing one both have to have or both not
+ * have this element, for this one to duplicate that one */
+ if (cBOOL(cp_list) != cBOOL(stored_cp_list_ptr)) {
+ continue;
+ }
+
+ /* If the inversion lists aren't equivalent, can't share */
+ if (cp_list && ! _invlistEQ(cp_list,
+ *stored_cp_list_ptr,
+ FALSE /* don't complement */))
+ {
+ continue;
+ }
+
+ /* Similarly for the other list */
+ SV ** stored_only_utf8_locale_list_ptr = av_fetch(
+ av,
+ ONLY_LOCALE_MATCHES_INDEX,
+ false /* no lvalue */);
+ if ( cBOOL(only_utf8_locale_list)
+ != cBOOL(stored_only_utf8_locale_list_ptr))
+ {
+ continue;
+ }
+
+ if (only_utf8_locale_list && ! _invlistEQ(
+ only_utf8_locale_list,
+ *stored_only_utf8_locale_list_ptr,
+ FALSE /* don't complement */))
+ {
+ continue;
+ }
+
+ /* Here, the existence and contents of both compile-time lists
+ * are identical between the new and existing data. Re-use the
+ * existing one */
+ ARG1u_SET(node, i);
+ return;
+ } /* end of loop through existing classes */
}
- else {
- AV * const av = newAV();
- SV *rv;
- if (cp_list) {
- av_store(av, INVLIST_INDEX, SvREFCNT_inc_NN(cp_list));
- }
+ /* Here, we need to create a new auxiliary data element; either because
+ * this doesn't duplicate an existing one, or we can't tell at this time if
+ * it eventually will */
- /* (Note that if any of this changes, the size calculations in
- * S_optimize_regclass() might need to be updated.) */
+ AV * const av = newAV();
+ SV *rv;
- if (only_utf8_locale_list) {
- av_store(av, ONLY_LOCALE_MATCHES_INDEX,
- SvREFCNT_inc_NN(only_utf8_locale_list));
- }
+ if (cp_list) {
+ av_store_simple(av, INVLIST_INDEX, SvREFCNT_inc_NN(cp_list));
+ }
- if (runtime_defns) {
- av_store(av, DEFERRED_USER_DEFINED_INDEX,
- SvREFCNT_inc_NN(runtime_defns));
- }
+ /* (Note that if any of this changes, the size calculations in
+ * S_optimize_regclass() might need to be updated.) */
- rv = newRV_noinc(MUTABLE_SV(av));
- n = add_data(pRExC_state, STR_WITH_LEN("s"));
- RExC_rxi->data->data[n] = (void*)rv;
- ARG_SET(node, n);
+ if (only_utf8_locale_list) {
+ av_store_simple(av, ONLY_LOCALE_MATCHES_INDEX,
+ SvREFCNT_inc_NN(only_utf8_locale_list));
}
+
+ if (runtime_defns) {
+ av_store_simple(av, DEFERRED_USER_DEFINED_INDEX,
+ SvREFCNT_inc_NN(runtime_defns));
+ }
+
+ rv = newRV_noinc(MUTABLE_SV(av));
+ n = reg_add_data(pRExC_state, STR_WITH_LEN("s"));
+ RExC_rxi->data->data[n] = (void*)rv;
+ ARG1u_SET(node, n);
}
+#endif /* PERL_RE_BUILD_AUX */
SV *
#if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
-Perl_get_regclass_nonbitmap_data(pTHX_ const regexp *prog, const regnode* node, bool doinit, SV** listsvp, SV** only_utf8_locale_ptr, SV** output_invlist)
+Perl_get_regclass_aux_data(pTHX_ const regexp *prog, const regnode* node, bool doinit, SV** listsvp, SV** only_utf8_locale_ptr, SV** output_invlist)
#else
-Perl_get_re_gclass_nonbitmap_data(pTHX_ const regexp *prog, const regnode* node, bool doinit, SV** listsvp, SV** only_utf8_locale_ptr, SV** output_invlist)
+Perl_get_re_gclass_aux_data(pTHX_ const regexp *prog, const regnode* node, bool doinit, SV** listsvp, SV** only_utf8_locale_ptr, SV** output_invlist)
#endif
{
/* For internal core use only.
* Returns the inversion list for the input 'node' in the regex 'prog'.
* If <doinit> is 'true', will attempt to create the inversion list if not
- * already done.
+ * already done. If it is created, it will add to the normal inversion
+ * list any that comes from user-defined properties. It croaks if this
+ * is called before such a list is ready to be generated, that is when a
+ * user-defined property has been declared, buyt still not yet defined.
* If <listsvp> is non-null, will return the printable contents of the
* property definition. This can be used to get debugging information
* even before the inversion list exists, by calling this function with
SV *si = NULL; /* Input initialization string */
SV* invlist = NULL;
- RXi_GET_DECL(prog, progi);
+ RXi_GET_DECL_NULL(prog, progi);
const struct reg_data * const data = prog ? progi->data : NULL;
#if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
- PERL_ARGS_ASSERT_GET_REGCLASS_NONBITMAP_DATA;
+ PERL_ARGS_ASSERT_GET_REGCLASS_AUX_DATA;
#else
- PERL_ARGS_ASSERT_GET_RE_GCLASS_NONBITMAP_DATA;
+ PERL_ARGS_ASSERT_GET_RE_GCLASS_AUX_DATA;
#endif
assert(! output_invlist || listsvp);
if (data && data->count) {
- const U32 n = ARG(node);
+ const U32 n = ARG1u(node);
- if (data->what[n] == 's') {
- SV * const rv = MUTABLE_SV(data->data[n]);
- AV * const av = MUTABLE_AV(SvRV(rv));
- SV **const ary = AvARRAY(av);
+ if (data->what[n] == 's') {
+ SV * const rv = MUTABLE_SV(data->data[n]);
+ AV * const av = MUTABLE_AV(SvRV(rv));
+ SV **const ary = AvARRAY(av);
invlist = ary[INVLIST_INDEX];
si = ary[DEFERRED_USER_DEFINED_INDEX];
}
- if (doinit && (si || invlist)) {
+ if (doinit && (si || invlist)) {
if (si) {
bool user_defined;
SV * msg = newSVpvs_flags("", SVs_TEMP);
: INVLIST_INDEX);
si = NULL;
}
- }
- }
+ }
+ }
}
/* If requested, return a printable version of what this ANYOF node matches
* */
if (listsvp) {
- SV* matches_string = NULL;
+ SV* matches_string = NULL;
/* This function can be called at compile-time, before everything gets
* resolved, in which case we return the currently best available
* information, which is the string that will eventually be used to do
* that resolving, 'si' */
- if (si) {
+ if (si) {
/* Here, we only have 'si' (and possibly some passed-in data in
* 'invlist', which is handled below) If the caller only wants
* 'si', use that. */
SvCUR_set(matches_string, SvCUR(matches_string) - 1);
}
} /* end of has an 'si' */
- }
+ }
/* Add the stuff that's already known */
if (invlist) {
}
}
- *listsvp = matches_string;
+ *listsvp = matches_string;
}
return invlist;
assert( ! UTF || UTF8_IS_INVARIANT(**p) || UTF8_IS_START(**p));
for (;;) {
- if (RExC_end - (*p) >= 3
- && *(*p) == '('
- && *(*p + 1) == '?'
- && *(*p + 2) == '#')
- {
- while (*(*p) != ')') {
- if ((*p) == RExC_end)
- FAIL("Sequence (?#... not terminated");
- (*p)++;
- }
- (*p)++;
- continue;
- }
-
- if (use_xmod) {
+ if (RExC_end - (*p) >= 3
+ && *(*p) == '('
+ && *(*p + 1) == '?'
+ && *(*p + 2) == '#')
+ {
+ while (*(*p) != ')') {
+ if ((*p) == RExC_end)
+ FAIL("Sequence (?#... not terminated");
+ (*p)++;
+ }
+ (*p)++;
+ continue;
+ }
+
+ if (use_xmod) {
const char * save_p = *p;
while ((*p) < RExC_end) {
STRLEN len;
if (*p != save_p) {
continue;
}
- }
+ }
break;
}
those two cases, the parse position is advanced beyond all such comments and
white space.
- This is the UTF, (?#...), and /x friendly way of saying RExC_parse++.
+ This is the UTF, (?#...), and /x friendly way of saying RExC_parse_inc_by(1).
*/
STATIC void
|| UTF8_IS_INVARIANT(*RExC_parse)
|| UTF8_IS_START(*RExC_parse));
- RExC_parse += (UTF)
- ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
- : 1;
+ RExC_parse_inc_safe();
skip_to_be_ignored_text(pRExC_state, &RExC_parse,
FALSE /* Don't force /x */ );
char,
regexp_internal);
if ( RExC_rxi == NULL )
- FAIL("Regexp out of space");
+ FAIL("Regexp out of space");
RXi_SET(RExC_rx, RExC_rxi);
RExC_emit_start = RExC_rxi->program;
if (size > 0) {
Zero(REGNODE_p(RExC_emit), size, regnode);
}
-
-#ifdef RE_TRACK_PATTERN_OFFSETS
- Renew(RExC_offsets, 2*RExC_size+1, U32);
- if (size > 0) {
- Zero(RExC_offsets + 2*(RExC_size - size) + 1, 2 * size, U32);
- }
- RExC_offsets[0] = RExC_size;
-#endif
}
STATIC regnode_offset
-S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 op, const STRLEN extra_size, const char* const name)
+S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const STRLEN extra_size)
{
- /* Allocate a regnode for 'op', with 'extra_size' extra (smallest) regnode
- * equivalents space. It aligns and increments RExC_size
+ /* Allocate a regnode that is (1 + extra_size) times as big as the
+ * smallest regnode worth of space, and also aligns and increments
+ * RExC_size appropriately.
*
* It returns the regnode's offset into the regex engine program */
const regnode_offset ret = RExC_emit;
- DECLARE_AND_GET_RE_DEBUG_FLAGS;
-
PERL_ARGS_ASSERT_REGNODE_GUTS;
SIZE_ALIGN(RExC_size);
change_engine_size(pRExC_state, (Ptrdiff_t) 1 + extra_size);
NODE_ALIGN_FILL(REGNODE_p(ret));
-#ifndef RE_TRACK_PATTERN_OFFSETS
- PERL_UNUSED_ARG(name);
- PERL_UNUSED_ARG(op);
-#else
- assert(extra_size >= regarglen[op] || PL_regkind[op] == ANYOF);
-
- if (RExC_offsets) { /* MJD */
- MJD_OFFSET_DEBUG(
- ("%s:%d: (op %s) %s %" UVuf " (len %" UVuf ") (max %" UVuf ").\n",
- name, __LINE__,
- PL_reg_name[op],
- (UV)(RExC_emit) > RExC_offsets[0]
- ? "Overwriting end of array!\n" : "OK",
- (UV)(RExC_emit),
- (UV)(RExC_parse - RExC_start),
- (UV)RExC_offsets[0]));
- Set_Node_Offset(REGNODE_p(RExC_emit), RExC_parse + (op == END));
- }
-#endif
return(ret);
}
+#ifdef DEBUGGING
+
+STATIC regnode_offset
+S_regnode_guts_debug(pTHX_ RExC_state_t *pRExC_state, const U8 op, const STRLEN extra_size) {
+ PERL_ARGS_ASSERT_REGNODE_GUTS_DEBUG;
+ assert(extra_size >= REGNODE_ARG_LEN(op) || REGNODE_TYPE(op) == ANYOF);
+ return S_regnode_guts(aTHX_ pRExC_state, extra_size);
+}
+
+#endif
+
+
+
/*
- reg_node - emit a node
*/
STATIC regnode_offset /* Location. */
S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
{
- const regnode_offset ret = regnode_guts(pRExC_state, op, regarglen[op], "reg_node");
+ const regnode_offset ret = REGNODE_GUTS(pRExC_state, op, REGNODE_ARG_LEN(op));
regnode_offset ptr = ret;
PERL_ARGS_ASSERT_REG_NODE;
- assert(regarglen[op] == 0);
+ assert(REGNODE_ARG_LEN(op) == 0);
FILL_ADVANCE_NODE(ptr, op);
RExC_emit = ptr;
}
/*
-- reganode - emit a node with an argument
+- reg1node - emit a node with an argument
*/
STATIC regnode_offset /* Location. */
-S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
+S_reg1node(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
{
- const regnode_offset ret = regnode_guts(pRExC_state, op, regarglen[op], "reganode");
+ const regnode_offset ret = REGNODE_GUTS(pRExC_state, op, REGNODE_ARG_LEN(op));
regnode_offset ptr = ret;
- PERL_ARGS_ASSERT_REGANODE;
+ PERL_ARGS_ASSERT_REG1NODE;
/* ANYOF are special cased to allow non-length 1 args */
- assert(regarglen[op] == 1);
+ assert(REGNODE_ARG_LEN(op) == 1);
- FILL_ADVANCE_NODE_ARG(ptr, op, arg);
+ FILL_ADVANCE_NODE_ARG1u(ptr, op, arg);
RExC_emit = ptr;
return(ret);
}
STATIC regnode_offset /* Location. */
S_regpnode(pTHX_ RExC_state_t *pRExC_state, U8 op, SV * arg)
{
- const regnode_offset ret = regnode_guts(pRExC_state, op, regarglen[op], "regpnode");
+ const regnode_offset ret = REGNODE_GUTS(pRExC_state, op, REGNODE_ARG_LEN(op));
regnode_offset ptr = ret;
PERL_ARGS_ASSERT_REGPNODE;
}
STATIC regnode_offset
-S_reg2Lanode(pTHX_ RExC_state_t *pRExC_state, const U8 op, const U32 arg1, const I32 arg2)
+S_reg2node(pTHX_ RExC_state_t *pRExC_state, const U8 op, const U32 arg1, const I32 arg2)
{
/* emit a node with U32 and I32 arguments */
- const regnode_offset ret = regnode_guts(pRExC_state, op, regarglen[op], "reg2Lanode");
+ const regnode_offset ret = REGNODE_GUTS(pRExC_state, op, REGNODE_ARG_LEN(op));
regnode_offset ptr = ret;
- PERL_ARGS_ASSERT_REG2LANODE;
+ PERL_ARGS_ASSERT_REG2NODE;
- assert(regarglen[op] == 2);
+ assert(REGNODE_ARG_LEN(op) == 2);
- FILL_ADVANCE_NODE_2L_ARG(ptr, op, arg1, arg2);
+ FILL_ADVANCE_NODE_2ui_ARG(ptr, op, arg1, arg2);
RExC_emit = ptr;
return(ret);
}
* set up NEXT_OFF() of the inserted node if needed. Something like this:
*
* reginsert(pRExC, OPFAIL, orig_emit, depth+1);
-* NEXT_OFF(orig_emit) = regarglen[OPFAIL] + NODE_STEP_REGNODE;
+* NEXT_OFF(REGNODE_p(orig_emit)) = REGNODE_ARG_LEN(OPFAIL) + NODE_STEP_REGNODE;
*
* ALSO NOTE - FLAGS(newly-inserted-operator) will be set to 0 as well.
*/
regnode *src;
regnode *dst;
regnode *place;
- const int offset = regarglen[(U8)op];
+ const int offset = REGNODE_ARG_LEN((U8)op);
const int size = NODE_STEP_REGNODE + offset;
DECLARE_AND_GET_RE_DEBUG_FLAGS;
PERL_ARGS_ASSERT_REGINSERT;
PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(depth);
-/* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
- DEBUG_PARSE_FMT("inst"," - %s", PL_reg_name[op]);
+ DEBUG_PARSE_FMT("inst"," - %s", REGNODE_NAME(op));
assert(!RExC_study_started); /* I believe we should never use reginsert once we have started
studying. If this is wrong then we need to adjust RExC_recurse
below like we do with RExC_open_parens/RExC_close_parens. */
RExC_end_op += size;
while (src > REGNODE_p(operand)) {
- StructCopy(--src, --dst, regnode);
-#ifdef RE_TRACK_PATTERN_OFFSETS
- if (RExC_offsets) { /* MJD 20010112 */
- MJD_OFFSET_DEBUG(
- ("%s(%d): (op %s) %s copy %" UVuf " -> %" UVuf " (max %" UVuf ").\n",
- "reginsert",
- __LINE__,
- PL_reg_name[op],
- (UV)(REGNODE_OFFSET(dst)) > RExC_offsets[0]
- ? "Overwriting end of array!\n" : "OK",
- (UV)REGNODE_OFFSET(src),
- (UV)REGNODE_OFFSET(dst),
- (UV)RExC_offsets[0]));
- Set_Node_Offset_To_R(REGNODE_OFFSET(dst), Node_Offset(src));
- Set_Node_Length_To_R(REGNODE_OFFSET(dst), Node_Length(src));
- }
-#endif
+ StructCopy(--src, --dst, regnode);
}
place = REGNODE_p(operand); /* Op node, where operand used to be. */
-#ifdef RE_TRACK_PATTERN_OFFSETS
- if (RExC_offsets) { /* MJD */
- MJD_OFFSET_DEBUG(
- ("%s(%d): (op %s) %s %" UVuf " <- %" UVuf " (max %" UVuf ").\n",
- "reginsert",
- __LINE__,
- PL_reg_name[op],
- (UV)REGNODE_OFFSET(place) > RExC_offsets[0]
- ? "Overwriting end of array!\n" : "OK",
- (UV)REGNODE_OFFSET(place),
- (UV)(RExC_parse - RExC_start),
- (UV)RExC_offsets[0]));
- Set_Node_Offset(place, RExC_parse);
- Set_Node_Length(place, 1);
- }
-#endif
- src = NEXTOPER(place);
+ src = place + 1; /* NOT REGNODE_AFTER! */
FLAGS(place) = 0;
FILL_NODE(operand, op);
* */
scan = (regnode_offset) p;
for (;;) {
- regnode * const temp = regnext(REGNODE_p(scan));
+ regnode * const temp = regnext(REGNODE_p(scan));
DEBUG_PARSE_r({
DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
regprop(RExC_rx, RExC_mysv, REGNODE_p(scan), NULL, pRExC_state);
Perl_re_printf( aTHX_ "~ %s (%zu) %s %s\n",
SvPV_nolen_const(RExC_mysv), scan,
(temp == NULL ? "->" : ""),
- (temp == NULL ? PL_reg_name[OP(REGNODE_p(val))] : "")
+ (temp == NULL ? REGNODE_NAME(OP(REGNODE_p(val))) : "")
);
});
if (temp == NULL)
/* Populate this node's next pointer */
assert(val >= scan);
- if (reg_off_by_arg[OP(REGNODE_p(scan))]) {
+ if (REGNODE_OFF_BY_ARG(OP(REGNODE_p(scan)))) {
assert((UV) (val - scan) <= U32_MAX);
- ARG_SET(REGNODE_p(scan), val - scan);
+ ARG1u_SET(REGNODE_p(scan), val - scan);
}
else {
if (val - scan > U16_MAX) {
for (;;) {
regnode * const temp = regnext(REGNODE_p(scan));
#ifdef EXPERIMENTAL_INPLACESCAN
- if (PL_regkind[OP(REGNODE_p(scan))] == EXACT) {
- bool unfolded_multi_char; /* Unexamined in this routine */
+ if (REGNODE_TYPE(OP(REGNODE_p(scan))) == EXACT) {
+ bool unfolded_multi_char; /* Unexamined in this routine */
if (join_exact(pRExC_state, scan, &min,
&unfolded_multi_char, 1, REGNODE_p(val), depth+1))
return TRUE; /* Was return EXACT */
- }
+ }
#endif
if ( exact ) {
- if (PL_regkind[OP(REGNODE_p(scan))] == EXACT) {
+ if (REGNODE_TYPE(OP(REGNODE_p(scan))) == EXACT) {
if (exact == PSEUDO )
exact= OP(REGNODE_p(scan));
else if (exact != OP(REGNODE_p(scan)) )
Perl_re_printf( aTHX_ "~ %s (%zu) -> %s\n",
SvPV_nolen_const(RExC_mysv),
scan,
- PL_reg_name[exact]);
+ REGNODE_NAME(exact));
});
- if (temp == NULL)
- break;
- scan = REGNODE_OFFSET(temp);
+ if (temp == NULL)
+ break;
+ scan = REGNODE_OFFSET(temp);
}
DEBUG_PARSE_r({
DEBUG_PARSE_MSG("");
regprop(RExC_rx, RExC_mysv, REGNODE_p(val), NULL, pRExC_state);
Perl_re_printf( aTHX_
"~ attach to %s (%" IVdf ") offset to %" IVdf "\n",
- SvPV_nolen_const(RExC_mysv),
- (IV)val,
- (IV)(val - scan)
+ SvPV_nolen_const(RExC_mysv),
+ (IV)val,
+ (IV)(val - scan)
);
});
- if (reg_off_by_arg[OP(REGNODE_p(scan))]) {
+ if (REGNODE_OFF_BY_ARG(OP(REGNODE_p(scan)))) {
assert((UV) (val - scan) <= U32_MAX);
- ARG_SET(REGNODE_p(scan), val - scan);
+ ARG1u_SET(REGNODE_p(scan), val - scan);
}
else {
if (val - scan > U16_MAX) {
NEXT_OFF(REGNODE_p(scan)) = U16_MAX;
return FALSE;
}
- NEXT_OFF(REGNODE_p(scan)) = val - scan;
+ NEXT_OFF(REGNODE_p(scan)) = val - scan;
}
return TRUE; /* Was 'return exact' */
}
#endif
-STATIC SV*
-S_get_ANYOFM_contents(pTHX_ const regnode * n) {
+
+#ifdef PERL_RE_BUILD_AUX
+SV*
+Perl_get_ANYOFM_contents(pTHX_ const regnode * n) {
/* Returns an inversion list of all the code points matched by the
* ANYOFM/NANYOFM node 'n' */
SV * cp_list = _new_invlist(-1);
- const U8 lowest = (U8) ARG(n);
+ const U8 lowest = (U8) ARG1u(n);
unsigned int i;
U8 count = 0;
U8 needed = 1U << PL_bitcount[ (U8) ~ FLAGS(n)];
/* Starting with the lowest code point, any code point that ANDed with the
* mask yields the lowest code point is in the set */
for (i = lowest; i <= 0xFF; i++) {
- if ((i & FLAGS(n)) == ARG(n)) {
+ if ((i & FLAGS(n)) == ARG1u(n)) {
cp_list = add_cp_to_invlist(cp_list, i);
count++;
return cp_list;
}
-/*
- - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
- */
-#ifdef DEBUGGING
-
-static void
-S_regdump_intflags(pTHX_ const char *lead, const U32 flags)
-{
- int bit;
- int set=0;
-
- ASSUME(REG_INTFLAGS_NAME_SIZE <= sizeof(flags)*8);
-
- for (bit=0; bit<REG_INTFLAGS_NAME_SIZE; bit++) {
- if (flags & (1<<bit)) {
- if (!set++ && lead)
- Perl_re_printf( aTHX_ "%s", lead);
- Perl_re_printf( aTHX_ "%s ", PL_reg_intflags_name[bit]);
- }
- }
- if (lead) {
- if (set)
- Perl_re_printf( aTHX_ "\n");
- else
- Perl_re_printf( aTHX_ "%s[none-set]\n", lead);
- }
-}
-
-static void
-S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
-{
- int bit;
- int set=0;
- regex_charset cs;
-
- ASSUME(REG_EXTFLAGS_NAME_SIZE <= sizeof(flags)*8);
-
- for (bit=0; bit<REG_EXTFLAGS_NAME_SIZE; bit++) {
- if (flags & (1<<bit)) {
- if ((1<<bit) & RXf_PMf_CHARSET) { /* Output separately, below */
- continue;
- }
- if (!set++ && lead)
- Perl_re_printf( aTHX_ "%s", lead);
- Perl_re_printf( aTHX_ "%s ", PL_reg_extflags_name[bit]);
- }
- }
- if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
- if (!set++ && lead) {
- Perl_re_printf( aTHX_ "%s", lead);
- }
- switch (cs) {
- case REGEX_UNICODE_CHARSET:
- Perl_re_printf( aTHX_ "UNICODE");
- break;
- case REGEX_LOCALE_CHARSET:
- Perl_re_printf( aTHX_ "LOCALE");
- break;
- case REGEX_ASCII_RESTRICTED_CHARSET:
- Perl_re_printf( aTHX_ "ASCII-RESTRICTED");
- break;
- case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
- Perl_re_printf( aTHX_ "ASCII-MORE_RESTRICTED");
- break;
- default:
- Perl_re_printf( aTHX_ "UNKNOWN CHARACTER SET");
- break;
- }
- }
- if (lead) {
- if (set)
- Perl_re_printf( aTHX_ "\n");
- else
- Perl_re_printf( aTHX_ "%s[none-set]\n", lead);
- }
-}
-#endif
-
-void
-Perl_regdump(pTHX_ const regexp *r)
-{
-#ifdef DEBUGGING
- int i;
- SV * const sv = sv_newmortal();
- SV *dsv= sv_newmortal();
- RXi_GET_DECL(r, ri);
- DECLARE_AND_GET_RE_DEBUG_FLAGS;
-
- PERL_ARGS_ASSERT_REGDUMP;
-
- (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
-
- /* Header fields of interest. */
- for (i = 0; i < 2; i++) {
- if (r->substrs->data[i].substr) {
- RE_PV_QUOTED_DECL(s, 0, dsv,
- SvPVX_const(r->substrs->data[i].substr),
- RE_SV_DUMPLEN(r->substrs->data[i].substr),
- PL_dump_re_max_len);
- Perl_re_printf( aTHX_
- "%s %s%s at %" IVdf "..%" UVuf " ",
- i ? "floating" : "anchored",
- s,
- RE_SV_TAIL(r->substrs->data[i].substr),
- (IV)r->substrs->data[i].min_offset,
- (UV)r->substrs->data[i].max_offset);
- }
- else if (r->substrs->data[i].utf8_substr) {
- RE_PV_QUOTED_DECL(s, 1, dsv,
- SvPVX_const(r->substrs->data[i].utf8_substr),
- RE_SV_DUMPLEN(r->substrs->data[i].utf8_substr),
- 30);
- Perl_re_printf( aTHX_
- "%s utf8 %s%s at %" IVdf "..%" UVuf " ",
- i ? "floating" : "anchored",
- s,
- RE_SV_TAIL(r->substrs->data[i].utf8_substr),
- (IV)r->substrs->data[i].min_offset,
- (UV)r->substrs->data[i].max_offset);
- }
- }
-
- if (r->check_substr || r->check_utf8)
- Perl_re_printf( aTHX_
- (const char *)
- ( r->check_substr == r->substrs->data[1].substr
- && r->check_utf8 == r->substrs->data[1].utf8_substr
- ? "(checking floating" : "(checking anchored"));
- if (r->intflags & PREGf_NOSCAN)
- Perl_re_printf( aTHX_ " noscan");
- if (r->extflags & RXf_CHECK_ALL)
- Perl_re_printf( aTHX_ " isall");
- if (r->check_substr || r->check_utf8)
- Perl_re_printf( aTHX_ ") ");
-
- if (ri->regstclass) {
- regprop(r, sv, ri->regstclass, NULL, NULL);
- Perl_re_printf( aTHX_ "stclass %s ", SvPVX_const(sv));
- }
- if (r->intflags & PREGf_ANCH) {
- Perl_re_printf( aTHX_ "anchored");
- if (r->intflags & PREGf_ANCH_MBOL)
- Perl_re_printf( aTHX_ "(MBOL)");
- if (r->intflags & PREGf_ANCH_SBOL)
- Perl_re_printf( aTHX_ "(SBOL)");
- if (r->intflags & PREGf_ANCH_GPOS)
- Perl_re_printf( aTHX_ "(GPOS)");
- Perl_re_printf( aTHX_ " ");
- }
- if (r->intflags & PREGf_GPOS_SEEN)
- Perl_re_printf( aTHX_ "GPOS:%" UVuf " ", (UV)r->gofs);
- if (r->intflags & PREGf_SKIP)
- Perl_re_printf( aTHX_ "plus ");
- if (r->intflags & PREGf_IMPLICIT)
- Perl_re_printf( aTHX_ "implicit ");
- Perl_re_printf( aTHX_ "minlen %" IVdf " ", (IV)r->minlen);
- if (r->extflags & RXf_EVAL_SEEN)
- Perl_re_printf( aTHX_ "with eval ");
- Perl_re_printf( aTHX_ "\n");
- DEBUG_FLAGS_r({
- regdump_extflags("r->extflags: ", r->extflags);
- regdump_intflags("r->intflags: ", r->intflags);
- });
-#else
- PERL_ARGS_ASSERT_REGDUMP;
- PERL_UNUSED_CONTEXT;
- PERL_UNUSED_ARG(r);
-#endif /* DEBUGGING */
-}
-
-/* Should be synchronized with ANYOF_ #defines in regcomp.h */
-#ifdef DEBUGGING
-
-# if _CC_WORDCHAR != 0 || _CC_DIGIT != 1 || _CC_ALPHA != 2 \
- || _CC_LOWER != 3 || _CC_UPPER != 4 || _CC_PUNCT != 5 \
- || _CC_PRINT != 6 || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8 \
- || _CC_CASED != 9 || _CC_SPACE != 10 || _CC_BLANK != 11 \
- || _CC_XDIGIT != 12 || _CC_CNTRL != 13 || _CC_ASCII != 14 \
- || _CC_VERTSPACE != 15
-# error Need to adjust order of anyofs[]
-# endif
-static const char * const anyofs[] = {
- "\\w",
- "\\W",
- "\\d",
- "\\D",
- "[:alpha:]",
- "[:^alpha:]",
- "[:lower:]",
- "[:^lower:]",
- "[:upper:]",
- "[:^upper:]",
- "[:punct:]",
- "[:^punct:]",
- "[:print:]",
- "[:^print:]",
- "[:alnum:]",
- "[:^alnum:]",
- "[:graph:]",
- "[:^graph:]",
- "[:cased:]",
- "[:^cased:]",
- "\\s",
- "\\S",
- "[:blank:]",
- "[:^blank:]",
- "[:xdigit:]",
- "[:^xdigit:]",
- "[:cntrl:]",
- "[:^cntrl:]",
- "[:ascii:]",
- "[:^ascii:]",
- "\\v",
- "\\V"
-};
-#endif
-
-/*
-- regprop - printable representation of opcode, with run time support
-*/
-
-void
-Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_info *reginfo, const RExC_state_t *pRExC_state)
-{
-#ifdef DEBUGGING
- int k;
- RXi_GET_DECL(prog, progi);
- DECLARE_AND_GET_RE_DEBUG_FLAGS;
-
- PERL_ARGS_ASSERT_REGPROP;
-
- SvPVCLEAR(sv);
-
- if (OP(o) > REGNODE_MAX) { /* regnode.type is unsigned */
- if (pRExC_state) { /* This gives more info, if we have it */
- FAIL3("panic: corrupted regexp opcode %d > %d",
- (int)OP(o), (int)REGNODE_MAX);
- }
- else {
- Perl_croak(aTHX_ "panic: corrupted regexp opcode %d > %d",
- (int)OP(o), (int)REGNODE_MAX);
- }
- }
- sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
-
- k = PL_regkind[OP(o)];
-
- if (k == EXACT) {
- sv_catpvs(sv, " ");
- /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
- * is a crude hack but it may be the best for now since
- * we have no flag "this EXACTish node was UTF-8"
- * --jhi */
- pv_pretty(sv, STRING(o), STR_LEN(o), PL_dump_re_max_len,
- PL_colors[0], PL_colors[1],
- PERL_PV_ESCAPE_UNI_DETECT |
- PERL_PV_ESCAPE_NONASCII |
- PERL_PV_PRETTY_ELLIPSES |
- PERL_PV_PRETTY_LTGT |
- PERL_PV_PRETTY_NOCLEAR
- );
- } else if (k == TRIE) {
- /* print the details of the trie in dumpuntil instead, as
- * progi->data isn't available here */
- const char op = OP(o);
- const U32 n = ARG(o);
- const reg_ac_data * const ac = IS_TRIE_AC(op) ?
- (reg_ac_data *)progi->data->data[n] :
- NULL;
- const reg_trie_data * const trie
- = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
-
- Perl_sv_catpvf(aTHX_ sv, "-%s", PL_reg_name[o->flags]);
- DEBUG_TRIE_COMPILE_r({
- if (trie->jump)
- sv_catpvs(sv, "(JUMP)");
- Perl_sv_catpvf(aTHX_ sv,
- "<S:%" UVuf "/%" IVdf " W:%" UVuf " L:%" UVuf "/%" UVuf " C:%" UVuf "/%" UVuf ">",
- (UV)trie->startstate,
- (IV)trie->statecount-1, /* -1 because of the unused 0 element */
- (UV)trie->wordcount,
- (UV)trie->minlen,
- (UV)trie->maxlen,
- (UV)TRIE_CHARCOUNT(trie),
- (UV)trie->uniquecharcount
- );
- });
- if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
- sv_catpvs(sv, "[");
- (void) put_charclass_bitmap_innards(sv,
- ((IS_ANYOF_TRIE(op))
- ? ANYOF_BITMAP(o)
- : TRIE_BITMAP(trie)),
- NULL,
- NULL,
- NULL,
- 0,
- FALSE
- );
- sv_catpvs(sv, "]");
- }
- } else if (k == CURLY) {
- U32 lo = ARG1(o), hi = ARG2(o);
- if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
- Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
- Perl_sv_catpvf(aTHX_ sv, "{%u,", (unsigned) lo);
- if (hi == REG_INFTY)
- sv_catpvs(sv, "INFTY");
- else
- Perl_sv_catpvf(aTHX_ sv, "%u", (unsigned) hi);
- sv_catpvs(sv, "}");
- }
- else if (k == WHILEM && o->flags) /* Ordinal/of */
- Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
- else if (k == REF || k == OPEN || k == CLOSE
- || k == GROUPP || OP(o)==ACCEPT)
- {
- AV *name_list= NULL;
- U32 parno= OP(o) == ACCEPT ? (U32)ARG2L(o) : ARG(o);
- Perl_sv_catpvf(aTHX_ sv, "%" UVuf, (UV)parno); /* Parenth number */
- if ( RXp_PAREN_NAMES(prog) ) {
- name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
- } else if ( pRExC_state ) {
- name_list= RExC_paren_name_list;
- }
- if (name_list) {
- if ( k != REF || (OP(o) < REFN)) {
- SV **name= av_fetch(name_list, parno, 0 );
- if (name)
- Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
- }
- else {
- SV *sv_dat= MUTABLE_SV(progi->data->data[ parno ]);
- I32 *nums=(I32*)SvPVX(sv_dat);
- SV **name= av_fetch(name_list, nums[0], 0 );
- I32 n;
- if (name) {
- for ( n=0; n<SvIVX(sv_dat); n++ ) {
- Perl_sv_catpvf(aTHX_ sv, "%s%" IVdf,
- (n ? "," : ""), (IV)nums[n]);
- }
- Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
- }
- }
- }
- if ( k == REF && reginfo) {
- U32 n = ARG(o); /* which paren pair */
- I32 ln = prog->offs[n].start;
- if (prog->lastparen < n || ln == -1 || prog->offs[n].end == -1)
- Perl_sv_catpvf(aTHX_ sv, ": FAIL");
- else if (ln == prog->offs[n].end)
- Perl_sv_catpvf(aTHX_ sv, ": ACCEPT - EMPTY STRING");
- else {
- const char *s = reginfo->strbeg + ln;
- Perl_sv_catpvf(aTHX_ sv, ": ");
- Perl_pv_pretty( aTHX_ sv, s, prog->offs[n].end - prog->offs[n].start, 32, 0, 0,
- PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_NOCLEAR|PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE );
- }
- }
- } else if (k == GOSUB) {
- AV *name_list= NULL;
- if ( RXp_PAREN_NAMES(prog) ) {
- name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
- } else if ( pRExC_state ) {
- name_list= RExC_paren_name_list;
- }
-
- /* Paren and offset */
- Perl_sv_catpvf(aTHX_ sv, "%d[%+d:%d]", (int)ARG(o),(int)ARG2L(o),
- (int)((o + (int)ARG2L(o)) - progi->program) );
- if (name_list) {
- SV **name= av_fetch(name_list, ARG(o), 0 );
- if (name)
- Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
- }
- }
- else if (k == LOGICAL)
- /* 2: embedded, otherwise 1 */
- Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);
- else if (k == ANYOF || k == ANYOFR) {
- U8 flags;
- char * bitmap;
- U32 arg;
- bool do_sep = FALSE; /* Do we need to separate various components of
- the output? */
- /* Set if there is still an unresolved user-defined property */
- SV *unresolved = NULL;
-
- /* Things that are ignored except when the runtime locale is UTF-8 */
- SV *only_utf8_locale_invlist = NULL;
-
- /* Code points that don't fit in the bitmap */
- SV *nonbitmap_invlist = NULL;
-
- /* And things that aren't in the bitmap, but are small enough to be */
- SV* bitmap_range_not_in_bitmap = NULL;
-
- bool inverted;
-
- if (inRANGE(OP(o), ANYOFH, ANYOFRb)) {
- flags = 0;
- bitmap = NULL;
- arg = 0;
- }
- else {
- flags = ANYOF_FLAGS(o);
- bitmap = ANYOF_BITMAP(o);
- arg = ARG(o);
- }
-
- if (OP(o) == ANYOFL || OP(o) == ANYOFPOSIXL) {
- if (ANYOFL_UTF8_LOCALE_REQD(flags)) {
- sv_catpvs(sv, "{utf8-locale-reqd}");
- }
- if (flags & ANYOFL_FOLD) {
- sv_catpvs(sv, "{i}");
- }
- }
-
- inverted = flags & ANYOF_INVERT;
-
- /* If there is stuff outside the bitmap, get it */
- if (arg != ANYOF_ONLY_HAS_BITMAP) {
- if (inRANGE(OP(o), ANYOFR, ANYOFRb)) {
- nonbitmap_invlist = _add_range_to_invlist(nonbitmap_invlist,
- ANYOFRbase(o),
- ANYOFRbase(o) + ANYOFRdelta(o));
- }
- else {
-#if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
- (void) get_regclass_nonbitmap_data(prog, o, FALSE,
- &unresolved,
- &only_utf8_locale_invlist,
- &nonbitmap_invlist);
-#else
- (void) get_re_gclass_nonbitmap_data(prog, o, FALSE,
- &unresolved,
- &only_utf8_locale_invlist,
- &nonbitmap_invlist);
-#endif
- }
-
- /* The non-bitmap data may contain stuff that could fit in the
- * bitmap. This could come from a user-defined property being
- * finally resolved when this call was done; or much more likely
- * because there are matches that require UTF-8 to be valid, and so
- * aren't in the bitmap (or ANYOFR). This is teased apart later */
- _invlist_intersection(nonbitmap_invlist,
- PL_InBitmap,
- &bitmap_range_not_in_bitmap);
- /* Leave just the things that don't fit into the bitmap */
- _invlist_subtract(nonbitmap_invlist,
- PL_InBitmap,
- &nonbitmap_invlist);
- }
-
- /* Obey this flag to add all above-the-bitmap code points */
- if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
- nonbitmap_invlist = _add_range_to_invlist(nonbitmap_invlist,
- NUM_ANYOF_CODE_POINTS,
- UV_MAX);
- }
-
- /* Ready to start outputting. First, the initial left bracket */
- Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
-
- /* ANYOFH by definition doesn't have anything that will fit inside the
- * bitmap; ANYOFR may or may not. */
- if ( ! inRANGE(OP(o), ANYOFH, ANYOFHr)
- && ( ! inRANGE(OP(o), ANYOFR, ANYOFRb)
- || ANYOFRbase(o) < NUM_ANYOF_CODE_POINTS))
- {
- /* Then all the things that could fit in the bitmap */
- do_sep = put_charclass_bitmap_innards(sv,
- bitmap,
- bitmap_range_not_in_bitmap,
- only_utf8_locale_invlist,
- o,
- flags,
-
- /* Can't try inverting for a
- * better display if there
- * are things that haven't
- * been resolved */
- unresolved != NULL
- || inRANGE(OP(o), ANYOFR, ANYOFRb));
- SvREFCNT_dec(bitmap_range_not_in_bitmap);
-
- /* If there are user-defined properties which haven't been defined
- * yet, output them. If the result is not to be inverted, it is
- * clearest to output them in a separate [] from the bitmap range
- * stuff. If the result is to be complemented, we have to show
- * everything in one [], as the inversion applies to the whole
- * thing. Use {braces} to separate them from anything in the
- * bitmap and anything above the bitmap. */
- if (unresolved) {
- if (inverted) {
- if (! do_sep) { /* If didn't output anything in the bitmap
- */
- sv_catpvs(sv, "^");
- }
- sv_catpvs(sv, "{");
- }
- else if (do_sep) {
- Perl_sv_catpvf(aTHX_ sv,"%s][%s", PL_colors[1],
- PL_colors[0]);
- }
- sv_catsv(sv, unresolved);
- if (inverted) {
- sv_catpvs(sv, "}");
- }
- do_sep = ! inverted;
- }
- }
-
- /* And, finally, add the above-the-bitmap stuff */
- if (nonbitmap_invlist && _invlist_len(nonbitmap_invlist)) {
- SV* contents;
-
- /* See if truncation size is overridden */
- const STRLEN dump_len = (PL_dump_re_max_len > 256)
- ? PL_dump_re_max_len
- : 256;
-
- /* This is output in a separate [] */
- if (do_sep) {
- Perl_sv_catpvf(aTHX_ sv,"%s][%s", PL_colors[1], PL_colors[0]);
- }
-
- /* And, for easy of understanding, it is shown in the
- * uncomplemented form if possible. The one exception being if
- * there are unresolved items, where the inversion has to be
- * delayed until runtime */
- if (inverted && ! unresolved) {
- _invlist_invert(nonbitmap_invlist);
- _invlist_subtract(nonbitmap_invlist, PL_InBitmap, &nonbitmap_invlist);
- }
-
- contents = invlist_contents(nonbitmap_invlist,
- FALSE /* output suitable for catsv */
- );
-
- /* If the output is shorter than the permissible maximum, just do it. */
- if (SvCUR(contents) <= dump_len) {
- sv_catsv(sv, contents);
- }
- else {
- const char * contents_string = SvPVX(contents);
- STRLEN i = dump_len;
-
- /* Otherwise, start at the permissible max and work back to the
- * first break possibility */
- while (i > 0 && contents_string[i] != ' ') {
- i--;
- }
- if (i == 0) { /* Fail-safe. Use the max if we couldn't
- find a legal break */
- i = dump_len;
- }
-
- sv_catpvn(sv, contents_string, i);
- sv_catpvs(sv, "...");
- }
-
- SvREFCNT_dec_NN(contents);
- SvREFCNT_dec_NN(nonbitmap_invlist);
- }
-
- /* And finally the matching, closing ']' */
- Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
-
- if (OP(o) == ANYOFHs) {
- Perl_sv_catpvf(aTHX_ sv, " (Leading UTF-8 bytes=%s", _byte_dump_string((U8 *) ((struct regnode_anyofhs *) o)->string, FLAGS(o), 1));
- }
- else if (inRANGE(OP(o), ANYOFH, ANYOFRb)) {
- U8 lowest = (OP(o) != ANYOFHr)
- ? FLAGS(o)
- : LOWEST_ANYOF_HRx_BYTE(FLAGS(o));
- U8 highest = (OP(o) == ANYOFHr)
- ? HIGHEST_ANYOF_HRx_BYTE(FLAGS(o))
- : (OP(o) == ANYOFH || OP(o) == ANYOFR)
- ? 0xFF
- : lowest;
-#ifndef EBCDIC
- if (OP(o) != ANYOFR || ! isASCII(ANYOFRbase(o) + ANYOFRdelta(o)))
-#endif
- {
- Perl_sv_catpvf(aTHX_ sv, " (First UTF-8 byte=%02X", lowest);
- if (lowest != highest) {
- Perl_sv_catpvf(aTHX_ sv, "-%02X", highest);
- }
- Perl_sv_catpvf(aTHX_ sv, ")");
- }
- }
-
- SvREFCNT_dec(unresolved);
- }
- else if (k == ANYOFM) {
- SV * cp_list = get_ANYOFM_contents(o);
-
- Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
- if (OP(o) == NANYOFM) {
- _invlist_invert(cp_list);
- }
-
- put_charclass_bitmap_innards(sv, NULL, cp_list, NULL, NULL, 0, TRUE);
- Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
-
- SvREFCNT_dec(cp_list);
- }
- else if (k == POSIXD || k == NPOSIXD) {
- U8 index = FLAGS(o) * 2;
- if (index < C_ARRAY_LENGTH(anyofs)) {
- if (*anyofs[index] != '[') {
- sv_catpvs(sv, "[");
- }
- sv_catpv(sv, anyofs[index]);
- if (*anyofs[index] != '[') {
- sv_catpvs(sv, "]");
- }
- }
- else {
- Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
- }
- }
- else if (k == BOUND || k == NBOUND) {
- /* Must be synced with order of 'bound_type' in regcomp.h */
- const char * const bounds[] = {
- "", /* Traditional */
- "{gcb}",
- "{lb}",
- "{sb}",
- "{wb}"
- };
- assert(FLAGS(o) < C_ARRAY_LENGTH(bounds));
- sv_catpv(sv, bounds[FLAGS(o)]);
- }
- else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH)) {
- Perl_sv_catpvf(aTHX_ sv, "[%d", -(o->flags));
- if (o->next_off) {
- Perl_sv_catpvf(aTHX_ sv, "..-%d", o->flags - o->next_off);
- }
- Perl_sv_catpvf(aTHX_ sv, "]");
- }
- else if (OP(o) == SBOL)
- Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^");
-
- /* add on the verb argument if there is one */
- if ( ( k == VERB || OP(o) == ACCEPT || OP(o) == OPFAIL ) && o->flags) {
- if ( ARG(o) )
- Perl_sv_catpvf(aTHX_ sv, ":%" SVf,
- SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
- else
- sv_catpvs(sv, ":NULL");
- }
-#else
- PERL_UNUSED_CONTEXT;
- PERL_UNUSED_ARG(sv);
- PERL_UNUSED_ARG(o);
- PERL_UNUSED_ARG(prog);
- PERL_UNUSED_ARG(reginfo);
- PERL_UNUSED_ARG(pRExC_state);
-#endif /* DEBUGGING */
+SV *
+Perl_get_ANYOFHbbm_contents(pTHX_ const regnode * n) {
+ PERL_ARGS_ASSERT_GET_ANYOFHBBM_CONTENTS;
+
+ SV * cp_list = NULL;
+ populate_invlist_from_bitmap(
+ ((struct regnode_bbm *) n)->bitmap,
+ REGNODE_BBM_BITMAP_LEN * CHARBITS,
+ &cp_list,
+
+ /* The base cp is from the start byte plus a zero continuation */
+ TWO_BYTE_UTF8_TO_NATIVE(FIRST_BYTE((struct regnode_bbm *) n),
+ UTF_CONTINUATION_MARK | 0));
+ return cp_list;
}
-
+#endif /* PERL_RE_BUILD_AUX */
SV *
PERL_UNUSED_CONTEXT;
DEBUG_COMPILE_r(
- {
- if (prog->maxlen > 0) {
+ {
+ if (prog->maxlen > 0 && (prog->check_utf8 || prog->check_substr)) {
const char * const s = SvPV_nolen_const(RX_UTF8(r)
- ? prog->check_utf8 : prog->check_substr);
+ ? prog->check_utf8 : prog->check_substr);
if (!PL_colorset) reginitcolors();
Perl_re_printf( aTHX_
- "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
- PL_colors[4],
- RX_UTF8(r) ? "utf8 " : "",
- PL_colors[5], PL_colors[0],
- s,
- PL_colors[1],
- (strlen(s) > PL_dump_re_max_len ? "..." : ""));
+ "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
+ PL_colors[4],
+ RX_UTF8(r) ? "utf8 " : "",
+ PL_colors[5], PL_colors[0],
+ s,
+ PL_colors[1],
+ (strlen(s) > PL_dump_re_max_len ? "..." : ""));
}
- } );
+ } );
/* use UTF8 check substring if regexp pattern itself is in UTF8 */
return RX_UTF8(r) ? prog->check_utf8 : prog->check_substr;
SvREFCNT_dec(r->substrs->data[i].substr);
SvREFCNT_dec(r->substrs->data[i].utf8_substr);
}
- Safefree(r->substrs);
+ Safefree(r->substrs);
}
RX_MATCH_COPY_FREE(rx);
#ifdef PERL_ANY_COW
SvREFCNT_dec(r->saved_copy);
#endif
- Safefree(r->offs);
+ Safefree(RXp_OFFSp(r));
+ if (r->logical_to_parno) {
+ Safefree(r->logical_to_parno);
+ Safefree(r->parno_to_logical);
+ Safefree(r->parno_to_logical_next);
+ }
+
SvREFCNT_dec(r->qr_anoncv);
if (r->recurse_locinput)
Safefree(r->recurse_locinput);
PERL_ARGS_ASSERT_REG_TEMP_COPY;
if (!dsv)
- dsv = (REGEXP*) newSV_type(SVt_REGEXP);
+ dsv = (REGEXP*) newSV_type(SVt_REGEXP);
else {
assert(SvTYPE(dsv) == SVt_REGEXP || (SvTYPE(dsv) == SVt_PVLV));
}
SvLEN_set(dsv, 0);
SvCUR_set(dsv, 0);
- SvOK_off((SV *)dsv);
+ SvOK_off((SV *)dsv);
- if (islv) {
- /* For PVLVs, the head (sv_any) points to an XPVLV, while
+ if (islv) {
+ /* For PVLVs, the head (sv_any) points to an XPVLV, while
* the LV's xpvlenu_rx will point to a regexp body, which
* we allocate here */
- REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
- assert(!SvPVX(dsv));
+ REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
+ assert(!SvPVX(dsv));
+ /* We "steal" the body from the newly allocated SV temp, changing
+ * the pointer in its HEAD to NULL. We then change its type to
+ * SVt_NULL so that when we immediately release its only reference,
+ * no memory deallocation happens.
+ *
+ * The body will eventually be freed (from the PVLV) either in
+ * Perl_sv_force_normal_flags() (if the PVLV is "downgraded" and
+ * the regexp body needs to be removed)
+ * or in Perl_sv_clear() (if the PVLV still holds the pointer until
+ * the PVLV itself is deallocated). */
((XPV*)SvANY(dsv))->xpv_len_u.xpvlenu_rx = temp->sv_any;
- temp->sv_any = NULL;
- SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
- SvREFCNT_dec_NN(temp);
- /* SvCUR still resides in the xpvlv struct, so the regexp copy-
- ing below will not set it. */
- SvCUR_set(dsv, SvCUR(ssv));
- }
+ temp->sv_any = NULL;
+ SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
+ SvREFCNT_dec_NN(temp);
+ /* SvCUR still resides in the xpvlv struct, so the regexp copy-
+ ing below will not set it. */
+ SvCUR_set(dsv, SvCUR(ssv));
+ }
}
/* This ensures that SvTHINKFIRST(sv) is true, and hence that
sv_force_normal(sv) is called. */
The string pointer is copied here, being part of the regexp struct.
*/
memcpy(&(drx->xpv_cur), &(srx->xpv_cur),
- sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
+ sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
+
if (!islv)
SvLEN_set(dsv, 0);
- if (srx->offs) {
+ if (RXp_OFFSp(srx)) {
const I32 npar = srx->nparens+1;
- Newx(drx->offs, npar, regexp_paren_pair);
- Copy(srx->offs, drx->offs, npar, regexp_paren_pair);
+ NewCopy(RXp_OFFSp(srx), RXp_OFFSp(drx), npar, regexp_paren_pair);
}
if (srx->substrs) {
int i;
Newx(drx->substrs, 1, struct reg_substr_data);
- StructCopy(srx->substrs, drx->substrs, struct reg_substr_data);
+ StructCopy(srx->substrs, drx->substrs, struct reg_substr_data);
for (i = 0; i < 2; i++) {
SvREFCNT_inc_void(drx->substrs->data[i].substr);
SvREFCNT_inc_void(drx->substrs->data[i].utf8_substr);
}
- /* check_substr and check_utf8, if non-NULL, point to either their
- anchored or float namesakes, and don't hold a second reference. */
+ /* check_substr and check_utf8, if non-NULL, point to either their
+ anchored or float namesakes, and don't hold a second reference. */
+ }
+ if (srx->logical_to_parno) {
+ NewCopy(srx->logical_to_parno,
+ drx->logical_to_parno,
+ srx->nparens+1, I32);
+ NewCopy(srx->parno_to_logical,
+ drx->parno_to_logical,
+ srx->nparens+1, I32);
+ NewCopy(srx->parno_to_logical_next,
+ drx->parno_to_logical_next,
+ srx->nparens+1, I32);
+ } else {
+ drx->logical_to_parno = NULL;
+ drx->parno_to_logical = NULL;
+ drx->parno_to_logical_next = NULL;
}
+ drx->logical_nparens = srx->logical_nparens;
+
RX_MATCH_COPIED_off(dsv);
#ifdef PERL_ANY_COW
- drx->saved_copy = NULL;
+ RXp_SAVED_COPY(drx) = NULL;
#endif
drx->mother_re = ReREFCNT_inc(srx->mother_re ? srx->mother_re : ssv);
SvREFCNT_inc_void(drx->qr_anoncv);
}
DEBUG_COMPILE_r({
- if (!PL_colorset)
- reginitcolors();
- {
- SV *dsv= sv_newmortal();
+ if (!PL_colorset)
+ reginitcolors();
+ {
+ SV *dsv= sv_newmortal();
RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
dsv, RX_PRECOMP(rx), RX_PRELEN(rx), PL_dump_re_max_len);
Perl_re_printf( aTHX_ "%sFreeing REx:%s %s\n",
}
});
-#ifdef RE_TRACK_PATTERN_OFFSETS
- if (ri->u.offsets)
- Safefree(ri->u.offsets); /* 20010421 MJD */
-#endif
if (ri->code_blocks)
S_free_codeblocks(aTHX_ ri->code_blocks);
if (ri->data) {
- int n = ri->data->count;
+ int n = ri->data->count;
- while (--n >= 0) {
+ while (--n >= 0) {
/* If you add a ->what type here, update the comment in regcomp.h */
- switch (ri->data->what[n]) {
- case 'a':
- case 'r':
- case 's':
- case 'S':
- case 'u':
- SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
- break;
- case 'f':
- Safefree(ri->data->data[n]);
- break;
- case 'l':
- case 'L':
- break;
+ switch (ri->data->what[n]) {
+ case 'a':
+ case 'r':
+ case 's':
+ case 'S':
+ case 'u':
+ SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
+ break;
+ case 'f':
+ Safefree(ri->data->data[n]);
+ break;
+ case 'l':
+ case 'L':
+ break;
case 'T':
{ /* Aho Corasick add-on structure for a trie node.
Used in stclass optimization only */
if ( !refcount ) {
PerlMemShared_free(aho->states);
PerlMemShared_free(aho->fail);
- /* do this last!!!! */
+ /* do this last!!!! */
PerlMemShared_free(ri->data->data[n]);
/* we should only ever get called once, so
* assert as much, and also guard the free
}
}
break;
- case 't':
- {
- /* trie structure. */
- U32 refcount;
- reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
+ case 't':
+ {
+ /* trie structure. */
+ U32 refcount;
+ reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
OP_REFCNT_LOCK;
refcount = --trie->refcount;
OP_REFCNT_UNLOCK;
PerlMemShared_free(trie->bitmap);
if (trie->jump)
PerlMemShared_free(trie->jump);
- PerlMemShared_free(trie->wordinfo);
+ if (trie->j_before_paren)
+ PerlMemShared_free(trie->j_before_paren);
+ if (trie->j_after_paren)
+ PerlMemShared_free(trie->j_after_paren);
+ PerlMemShared_free(trie->wordinfo);
/* do this last!!!! */
PerlMemShared_free(ri->data->data[n]);
- }
- }
- break;
- default:
- Perl_croak(aTHX_ "panic: regfree data code '%c'",
+ }
+ }
+ break;
+ case '%':
+ /* NO-OP a '%' data contains a null pointer, so that reg_add_data
+ * always returns non-zero, this should only ever happen in the
+ * 0 index */
+ assert(n==0);
+ break;
+ default:
+ Perl_croak(aTHX_ "panic: regfree data code '%c'",
ri->data->what[n]);
- }
- }
- Safefree(ri->data->what);
- Safefree(ri->data);
+ }
+ }
+ Safefree(ri->data->what);
+ Safefree(ri->data);
}
Safefree(ri);
}
-#define av_dup_inc(s, t) MUTABLE_AV(sv_dup_inc((const SV *)s, t))
-#define hv_dup_inc(s, t) MUTABLE_HV(sv_dup_inc((const SV *)s, t))
#define SAVEPVN(p, n) ((p) ? savepvn(p, n) : NULL)
/*
PERL_ARGS_ASSERT_RE_DUP_GUTS;
npar = r->nparens+1;
- Newx(ret->offs, npar, regexp_paren_pair);
- Copy(r->offs, ret->offs, npar, regexp_paren_pair);
+ NewCopy(RXp_OFFSp(r), RXp_OFFSp(ret), npar, regexp_paren_pair);
if (ret->substrs) {
- /* Do it this way to avoid reading from *r after the StructCopy().
- That way, if any of the sv_dup_inc()s dislodge *r from the L1
- cache, it doesn't matter. */
+ /* Do it this way to avoid reading from *r after the StructCopy().
+ That way, if any of the sv_dup_inc()s dislodge *r from the L1
+ cache, it doesn't matter. */
int i;
- const bool anchored = r->check_substr
- ? r->check_substr == r->substrs->data[0].substr
- : r->check_utf8 == r->substrs->data[0].utf8_substr;
+ const bool anchored = r->check_substr
+ ? r->check_substr == r->substrs->data[0].substr
+ : r->check_utf8 == r->substrs->data[0].utf8_substr;
Newx(ret->substrs, 1, struct reg_substr_data);
- StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
+ StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
for (i = 0; i < 2; i++) {
ret->substrs->data[i].substr =
sv_dup_inc(ret->substrs->data[i].utf8_substr, param);
}
- /* check_substr and check_utf8, if non-NULL, point to either their
- anchored or float namesakes, and don't hold a second reference. */
-
- if (ret->check_substr) {
- if (anchored) {
- assert(r->check_utf8 == r->substrs->data[0].utf8_substr);
-
- ret->check_substr = ret->substrs->data[0].substr;
- ret->check_utf8 = ret->substrs->data[0].utf8_substr;
- } else {
- assert(r->check_substr == r->substrs->data[1].substr);
- assert(r->check_utf8 == r->substrs->data[1].utf8_substr);
-
- ret->check_substr = ret->substrs->data[1].substr;
- ret->check_utf8 = ret->substrs->data[1].utf8_substr;
- }
- } else if (ret->check_utf8) {
- if (anchored) {
- ret->check_utf8 = ret->substrs->data[0].utf8_substr;
- } else {
- ret->check_utf8 = ret->substrs->data[1].utf8_substr;
- }
- }
+ /* check_substr and check_utf8, if non-NULL, point to either their
+ anchored or float namesakes, and don't hold a second reference. */
+
+ if (ret->check_substr) {
+ if (anchored) {
+ assert(r->check_utf8 == r->substrs->data[0].utf8_substr);
+
+ ret->check_substr = ret->substrs->data[0].substr;
+ ret->check_utf8 = ret->substrs->data[0].utf8_substr;
+ } else {
+ assert(r->check_substr == r->substrs->data[1].substr);
+ assert(r->check_utf8 == r->substrs->data[1].utf8_substr);
+
+ ret->check_substr = ret->substrs->data[1].substr;
+ ret->check_utf8 = ret->substrs->data[1].utf8_substr;
+ }
+ } else if (ret->check_utf8) {
+ if (anchored) {
+ ret->check_utf8 = ret->substrs->data[0].utf8_substr;
+ } else {
+ ret->check_utf8 = ret->substrs->data[1].utf8_substr;
+ }
+ }
}
RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
Newx(ret->recurse_locinput, r->nparens + 1, char *);
if (ret->pprivate)
- RXi_SET(ret, CALLREGDUPE_PVT(dstr, param));
+ RXi_SET(ret, CALLREGDUPE_PVT(dstr, param));
if (RX_MATCH_COPIED(dstr))
- ret->subbeg = SAVEPVN(ret->subbeg, ret->sublen);
+ RXp_SUBBEG(ret) = SAVEPVN(RXp_SUBBEG(ret), RXp_SUBLEN(ret));
else
- ret->subbeg = NULL;
+ RXp_SUBBEG(ret) = NULL;
#ifdef PERL_ANY_COW
- ret->saved_copy = NULL;
+ RXp_SAVED_COPY(ret) = NULL;
#endif
+ if (r->logical_to_parno) {
+ /* we use total_parens for all three just for symmetry */
+ ret->logical_to_parno = (I32*)SAVEPVN((char*)(r->logical_to_parno), (1+r->nparens) * sizeof(I32));
+ ret->parno_to_logical = (I32*)SAVEPVN((char*)(r->parno_to_logical), (1+r->nparens) * sizeof(I32));
+ ret->parno_to_logical_next = (I32*)SAVEPVN((char*)(r->parno_to_logical_next), (1+r->nparens) * sizeof(I32));
+ } else {
+ ret->logical_to_parno = NULL;
+ ret->parno_to_logical = NULL;
+ ret->parno_to_logical_next = NULL;
+ }
+
+ ret->logical_nparens = r->logical_nparens;
+
/* Whether mother_re be set or no, we need to copy the string. We
cannot refrain from copying it when the storage points directly to
our mother regexp, because that's
- 1: a buffer in a different thread
- 2: something we no longer hold a reference on
- so we need to copy it locally. */
+ 1: a buffer in a different thread
+ 2: something we no longer hold a reference on
+ so we need to copy it locally. */
RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED_const(sstr), SvCUR(sstr)+1);
/* set malloced length to a non-zero value so it will be freed
* (otherwise in combination with SVf_FAKE it looks like an alien
if (ri->code_blocks) {
- int n;
- Newx(reti->code_blocks, 1, struct reg_code_blocks);
- Newx(reti->code_blocks->cb, ri->code_blocks->count,
+ int n;
+ Newx(reti->code_blocks, 1, struct reg_code_blocks);
+ Newx(reti->code_blocks->cb, ri->code_blocks->count,
struct reg_code_block);
- Copy(ri->code_blocks->cb, reti->code_blocks->cb,
+ Copy(ri->code_blocks->cb, reti->code_blocks->cb,
ri->code_blocks->count, struct reg_code_block);
- for (n = 0; n < ri->code_blocks->count; n++)
- reti->code_blocks->cb[n].src_regex = (REGEXP*)
- sv_dup_inc((SV*)(ri->code_blocks->cb[n].src_regex), param);
+ for (n = 0; n < ri->code_blocks->count; n++)
+ reti->code_blocks->cb[n].src_regex = (REGEXP*)
+ sv_dup_inc((SV*)(ri->code_blocks->cb[n].src_regex), param);
reti->code_blocks->count = ri->code_blocks->count;
reti->code_blocks->refcnt = 1;
}
else
- reti->code_blocks = NULL;
+ reti->code_blocks = NULL;
reti->regstclass = NULL;
if (ri->data) {
- struct reg_data *d;
+ struct reg_data *d;
const int count = ri->data->count;
- int i;
+ int i;
- Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
- char, struct reg_data);
- Newx(d->what, count, U8);
+ Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
+ char, struct reg_data);
+ Newx(d->what, count, U8);
- d->count = count;
- for (i = 0; i < count; i++) {
- d->what[i] = ri->data->what[i];
- switch (d->what[i]) {
- /* see also regcomp.h and regfree_internal() */
+ d->count = count;
+ for (i = 0; i < count; i++) {
+ d->what[i] = ri->data->what[i];
+ switch (d->what[i]) {
+ /* see also regcomp.h and regfree_internal() */
case 'a': /* actually an AV, but the dup function is identical.
values seem to be "plain sv's" generally. */
case 'r': /* a compiled regex (but still just another SV) */
case 'S': /* actually an SV, but the dup function is identical. */
case 'u': /* actually an HV, but the dup function is identical.
values are "plain sv's" */
- d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
- break;
- case 'f':
+ d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
+ break;
+ case 'f':
/* Synthetic Start Class - "Fake" charclass we generate to optimize
* patterns which could start with several different things. Pre-TRIE
* this was more important than it is now, however this still helps
* to [xa]. This is used by Perl_re_intuit_start() and S_find_byclass()
* in regexec.c
*/
- /* This is cheating. */
- Newx(d->data[i], 1, regnode_ssc);
- StructCopy(ri->data->data[i], d->data[i], regnode_ssc);
- reti->regstclass = (regnode*)d->data[i];
- break;
- case 'T':
+ /* This is cheating. */
+ Newx(d->data[i], 1, regnode_ssc);
+ StructCopy(ri->data->data[i], d->data[i], regnode_ssc);
+ reti->regstclass = (regnode*)d->data[i];
+ break;
+ case 'T':
/* AHO-CORASICK fail table */
/* Trie stclasses are readonly and can thus be shared
- * without duplication. We free the stclass in pregfree
- * when the corresponding reg_ac_data struct is freed.
- */
- reti->regstclass= ri->regstclass;
- /* FALLTHROUGH */
- case 't':
+ * without duplication. We free the stclass in pregfree
+ * when the corresponding reg_ac_data struct is freed.
+ */
+ reti->regstclass= ri->regstclass;
+ /* FALLTHROUGH */
+ case 't':
/* TRIE transition table */
- OP_REFCNT_LOCK;
- ((reg_trie_data*)ri->data->data[i])->refcount++;
- OP_REFCNT_UNLOCK;
- /* FALLTHROUGH */
+ OP_REFCNT_LOCK;
+ ((reg_trie_data*)ri->data->data[i])->refcount++;
+ OP_REFCNT_UNLOCK;
+ /* FALLTHROUGH */
case 'l': /* (?{...}) or (??{ ... }) code (cb->block) */
case 'L': /* same when RExC_pm_flags & PMf_HAS_CV and code
is not from another regexp */
- d->data[i] = ri->data->data[i];
- break;
+ d->data[i] = ri->data->data[i];
+ break;
+ case '%':
+ /* this is a placeholder type, it exists purely so that
+ * reg_add_data always returns a non-zero value, this type of
+ * entry should ONLY be present in the 0 slot of the array */
+ assert(i == 0);
+ d->data[i]= ri->data->data[i];
+ break;
default:
Perl_croak(aTHX_ "panic: re_dup_guts unknown data code '%c'",
ri->data->what[i]);
- }
- }
+ }
+ }
- reti->data = d;
+ reti->data = d;
}
else
- reti->data = NULL;
+ reti->data = NULL;
+
+ if (ri->regstclass && !reti->regstclass) {
+ /* Assume that the regstclass is a regnode which is inside of the
+ * program which we have to copy over */
+ regnode *node= ri->regstclass;
+ assert(node >= ri->program && (node - ri->program) < len);
+ reti->regstclass = reti->program + (node - ri->program);
+ }
+
reti->name_list_idx = ri->name_list_idx;
-#ifdef RE_TRACK_PATTERN_OFFSETS
- if (ri->u.offsets) {
- Newx(reti->u.offsets, 2*len+1, U32);
- Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
- }
-#else
SetProgLen(reti, len);
-#endif
return (void*)reti;
}
#endif /* USE_ITHREADS */
-#ifndef PERL_IN_XSUB_RE
-
-/*
- - regnext - dig the "next" pointer out of a node
- */
-regnode *
-Perl_regnext(pTHX_ regnode *p)
-{
- I32 offset;
-
- if (!p)
- return(NULL);
-
- if (OP(p) > REGNODE_MAX) { /* regnode.type is unsigned */
- Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
- (int)OP(p), (int)REGNODE_MAX);
- }
-
- offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
- if (offset == 0)
- return(NULL);
-
- return(p+offset);
-}
-
-#endif
-
STATIC void
S_re_croak(pTHX_ bool utf8, const char* pat,...)
{
PERL_ARGS_ASSERT_RE_CROAK;
if (len > 510)
- len = 510;
+ len = 510;
Copy(pat, buf, len , char);
buf[len] = '\n';
buf[len + 1] = '\0';
va_end(args);
message = SvPV_const(msv, len);
if (len > 512)
- len = 512;
+ len = 512;
Copy(message, buf, len , char);
/* len-1 to avoid \n */
Perl_croak(aTHX_ "%" UTF8f, UTF8fARG(utf8, len-1, buf));
/* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
if (PL_curpm) {
- const REGEXP * const rx = PM_GETRE(PL_curpm);
- if (rx)
+ const REGEXP * const rx = PM_GETRE(PL_curpm);
+ if (rx)
nparens = RX_NPARENS(rx);
}
}
#endif
-#ifdef DEBUGGING
-
-STATIC void
-S_put_code_point(pTHX_ SV *sv, UV c)
-{
- PERL_ARGS_ASSERT_PUT_CODE_POINT;
-
- if (c > 255) {
- Perl_sv_catpvf(aTHX_ sv, "\\x{%04" UVXf "}", c);
- }
- else if (isPRINT(c)) {
- const char string = (char) c;
-
- /* We use {phrase} as metanotation in the class, so also escape literal
- * braces */
- if (isBACKSLASHED_PUNCT(c) || c == '{' || c == '}')
- sv_catpvs(sv, "\\");
- sv_catpvn(sv, &string, 1);
- }
- else if (isMNEMONIC_CNTRL(c)) {
- Perl_sv_catpvf(aTHX_ sv, "%s", cntrl_to_mnemonic((U8) c));
- }
- else {
- Perl_sv_catpvf(aTHX_ sv, "\\x%02X", (U8) c);
- }
-}
-
-STATIC void
-S_put_range(pTHX_ SV *sv, UV start, const UV end, const bool allow_literals)
-{
- /* Appends to 'sv' a displayable version of the range of code points from
- * 'start' to 'end'. Mnemonics (like '\r') are used for the few controls
- * that have them, when they occur at the beginning or end of the range.
- * It uses hex to output the remaining code points, unless 'allow_literals'
- * is true, in which case the printable ASCII ones are output as-is (though
- * some of these will be escaped by put_code_point()).
- *
- * NOTE: This is designed only for printing ranges of code points that fit
- * inside an ANYOF bitmap. Higher code points are simply suppressed
- */
-
- const unsigned int min_range_count = 3;
-
- assert(start <= end);
-
- PERL_ARGS_ASSERT_PUT_RANGE;
-
- while (start <= end) {
- UV this_end;
- const char * format;
-
- if ( end - start < min_range_count
- && (end - start <= 2 || (isPRINT_A(start) && isPRINT_A(end))))
- {
- /* Output a range of 1 or 2 chars individually, or longer ranges
- * when printable */
- for (; start <= end; start++) {
- put_code_point(sv, start);
- }
- break;
- }
-
- /* If permitted by the input options, and there is a possibility that
- * this range contains a printable literal, look to see if there is
- * one. */
- if (allow_literals && start <= MAX_PRINT_A) {
-
- /* If the character at the beginning of the range isn't an ASCII
- * printable, effectively split the range into two parts:
- * 1) the portion before the first such printable,
- * 2) the rest
- * and output them separately. */
- if (! isPRINT_A(start)) {
- UV temp_end = start + 1;
-
- /* There is no point looking beyond the final possible
- * printable, in MAX_PRINT_A */
- UV max = MIN(end, MAX_PRINT_A);
-
- while (temp_end <= max && ! isPRINT_A(temp_end)) {
- temp_end++;
- }
-
- /* Here, temp_end points to one beyond the first printable if
- * found, or to one beyond 'max' if not. If none found, make
- * sure that we use the entire range */
- if (temp_end > MAX_PRINT_A) {
- temp_end = end + 1;
- }
-
- /* Output the first part of the split range: the part that
- * doesn't have printables, with the parameter set to not look
- * for literals (otherwise we would infinitely recurse) */
- put_range(sv, start, temp_end - 1, FALSE);
-
- /* The 2nd part of the range (if any) starts here. */
- start = temp_end;
-
- /* We do a continue, instead of dropping down, because even if
- * the 2nd part is non-empty, it could be so short that we want
- * to output it as individual characters, as tested for at the
- * top of this loop. */
- continue;
- }
-
- /* Here, 'start' is a printable ASCII. If it is an alphanumeric,
- * output a sub-range of just the digits or letters, then process
- * the remaining portion as usual. */
- if (isALPHANUMERIC_A(start)) {
- UV mask = (isDIGIT_A(start))
- ? _CC_DIGIT
- : isUPPER_A(start)
- ? _CC_UPPER
- : _CC_LOWER;
- UV temp_end = start + 1;
-
- /* Find the end of the sub-range that includes just the
- * characters in the same class as the first character in it */
- while (temp_end <= end && _generic_isCC_A(temp_end, mask)) {
- temp_end++;
- }
- temp_end--;
-
- /* For short ranges, don't duplicate the code above to output
- * them; just call recursively */
- if (temp_end - start < min_range_count) {
- put_range(sv, start, temp_end, FALSE);
- }
- else { /* Output as a range */
- put_code_point(sv, start);
- sv_catpvs(sv, "-");
- put_code_point(sv, temp_end);
- }
- start = temp_end + 1;
- continue;
- }
-
- /* We output any other printables as individual characters */
- if (isPUNCT_A(start) || isSPACE_A(start)) {
- while (start <= end && (isPUNCT_A(start)
- || isSPACE_A(start)))
- {
- put_code_point(sv, start);
- start++;
- }
- continue;
- }
- } /* End of looking for literals */
-
- /* Here is not to output as a literal. Some control characters have
- * mnemonic names. Split off any of those at the beginning and end of
- * the range to print mnemonically. It isn't possible for many of
- * these to be in a row, so this won't overwhelm with output */
- if ( start <= end
- && (isMNEMONIC_CNTRL(start) || isMNEMONIC_CNTRL(end)))
- {
- while (isMNEMONIC_CNTRL(start) && start <= end) {
- put_code_point(sv, start);
- start++;
- }
-
- /* If this didn't take care of the whole range ... */
- if (start <= end) {
-
- /* Look backwards from the end to find the final non-mnemonic
- * */
- UV temp_end = end;
- while (isMNEMONIC_CNTRL(temp_end)) {
- temp_end--;
- }
-
- /* And separately output the interior range that doesn't start
- * or end with mnemonics */
- put_range(sv, start, temp_end, FALSE);
-
- /* Then output the mnemonic trailing controls */
- start = temp_end + 1;
- while (start <= end) {
- put_code_point(sv, start);
- start++;
- }
- break;
- }
- }
-
- /* As a final resort, output the range or subrange as hex. */
-
- if (start >= NUM_ANYOF_CODE_POINTS) {
- this_end = end;
- }
- else { /* Have to split range at the bitmap boundary */
- this_end = (end < NUM_ANYOF_CODE_POINTS)
- ? end
- : NUM_ANYOF_CODE_POINTS - 1;
- }
-#if NUM_ANYOF_CODE_POINTS > 256
- format = (this_end < 256)
- ? "\\x%02" UVXf "-\\x%02" UVXf
- : "\\x{%04" UVXf "}-\\x{%04" UVXf "}";
-#else
- format = "\\x%02" UVXf "-\\x%02" UVXf;
-#endif
- GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
- Perl_sv_catpvf(aTHX_ sv, format, start, this_end);
- GCC_DIAG_RESTORE_STMT;
- break;
- }
-}
-
-STATIC void
-S_put_charclass_bitmap_innards_invlist(pTHX_ SV *sv, SV* invlist)
-{
- /* Concatenate onto the PV in 'sv' a displayable form of the inversion list
- * 'invlist' */
-
- UV start, end;
- bool allow_literals = TRUE;
-
- PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_INVLIST;
-
- /* Generally, it is more readable if printable characters are output as
- * literals, but if a range (nearly) spans all of them, it's best to output
- * it as a single range. This code will use a single range if all but 2
- * ASCII printables are in it */
- invlist_iterinit(invlist);
- while (invlist_iternext(invlist, &start, &end)) {
-
- /* If the range starts beyond the final printable, it doesn't have any
- * in it */
- if (start > MAX_PRINT_A) {
- break;
- }
-
- /* In both ASCII and EBCDIC, a SPACE is the lowest printable. To span
- * all but two, the range must start and end no later than 2 from
- * either end */
- if (start < ' ' + 2 && end > MAX_PRINT_A - 2) {
- if (end > MAX_PRINT_A) {
- end = MAX_PRINT_A;
- }
- if (start < ' ') {
- start = ' ';
- }
- if (end - start >= MAX_PRINT_A - ' ' - 2) {
- allow_literals = FALSE;
- }
- break;
- }
- }
- invlist_iterfinish(invlist);
-
- /* Here we have figured things out. Output each range */
- invlist_iterinit(invlist);
- while (invlist_iternext(invlist, &start, &end)) {
- if (start >= NUM_ANYOF_CODE_POINTS) {
- break;
- }
- put_range(sv, start, end, allow_literals);
- }
- invlist_iterfinish(invlist);
-
- return;
-}
-
-STATIC SV*
-S_put_charclass_bitmap_innards_common(pTHX_
- SV* invlist, /* The bitmap */
- SV* posixes, /* Under /l, things like [:word:], \S */
- SV* only_utf8, /* Under /d, matches iff the target is UTF-8 */
- SV* not_utf8, /* /d, matches iff the target isn't UTF-8 */
- SV* only_utf8_locale, /* Under /l, matches if the locale is UTF-8 */
- const bool invert /* Is the result to be inverted? */
-)
-{
- /* Create and return an SV containing a displayable version of the bitmap
- * and associated information determined by the input parameters. If the
- * output would have been only the inversion indicator '^', NULL is instead
- * returned. */
-
- SV * output;
-
- PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_COMMON;
-
- if (invert) {
- output = newSVpvs("^");
- }
- else {
- output = newSVpvs("");
- }
-
- /* First, the code points in the bitmap that are unconditionally there */
- put_charclass_bitmap_innards_invlist(output, invlist);
-
- /* Traditionally, these have been placed after the main code points */
- if (posixes) {
- sv_catsv(output, posixes);
- }
-
- if (only_utf8 && _invlist_len(only_utf8)) {
- Perl_sv_catpvf(aTHX_ output, "%s{utf8}%s", PL_colors[1], PL_colors[0]);
- put_charclass_bitmap_innards_invlist(output, only_utf8);
- }
-
- if (not_utf8 && _invlist_len(not_utf8)) {
- Perl_sv_catpvf(aTHX_ output, "%s{not utf8}%s", PL_colors[1], PL_colors[0]);
- put_charclass_bitmap_innards_invlist(output, not_utf8);
- }
-
- if (only_utf8_locale && _invlist_len(only_utf8_locale)) {
- Perl_sv_catpvf(aTHX_ output, "%s{utf8 locale}%s", PL_colors[1], PL_colors[0]);
- put_charclass_bitmap_innards_invlist(output, only_utf8_locale);
-
- /* This is the only list in this routine that can legally contain code
- * points outside the bitmap range. The call just above to
- * 'put_charclass_bitmap_innards_invlist' will simply suppress them, so
- * output them here. There's about a half-dozen possible, and none in
- * contiguous ranges longer than 2 */
- if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
- UV start, end;
- SV* above_bitmap = NULL;
-
- _invlist_subtract(only_utf8_locale, PL_InBitmap, &above_bitmap);
-
- invlist_iterinit(above_bitmap);
- while (invlist_iternext(above_bitmap, &start, &end)) {
- UV i;
-
- for (i = start; i <= end; i++) {
- put_code_point(output, i);
- }
- }
- invlist_iterfinish(above_bitmap);
- SvREFCNT_dec_NN(above_bitmap);
- }
- }
-
- if (invert && SvCUR(output) == 1) {
- return NULL;
- }
-
- return output;
-}
-
-STATIC bool
-S_put_charclass_bitmap_innards(pTHX_ SV *sv,
- char *bitmap,
- SV *nonbitmap_invlist,
- SV *only_utf8_locale_invlist,
- const regnode * const node,
- const U8 flags,
- const bool force_as_is_display)
-{
- /* Appends to 'sv' a displayable version of the innards of the bracketed
- * character class defined by the other arguments:
- * 'bitmap' points to the bitmap, or NULL if to ignore that.
- * 'nonbitmap_invlist' is an inversion list of the code points that are in
- * the bitmap range, but for some reason aren't in the bitmap; NULL if
- * none. The reasons for this could be that they require some
- * condition such as the target string being or not being in UTF-8
- * (under /d), or because they came from a user-defined property that
- * was not resolved at the time of the regex compilation (under /u)
- * 'only_utf8_locale_invlist' is an inversion list of the code points that
- * are valid only if the runtime locale is a UTF-8 one; NULL if none
- * 'node' is the regex pattern ANYOF node. It is needed only when the
- * above two parameters are not null, and is passed so that this
- * routine can tease apart the various reasons for them.
- * 'flags' is the flags field of 'node'
- * 'force_as_is_display' is TRUE if this routine should definitely NOT try
- * to invert things to see if that leads to a cleaner display. If
- * FALSE, this routine is free to use its judgment about doing this.
- *
- * It returns TRUE if there was actually something output. (It may be that
- * the bitmap, etc is empty.)
- *
- * When called for outputting the bitmap of a non-ANYOF node, just pass the
- * bitmap, with the succeeding parameters set to NULL, and the final one to
- * FALSE.
- */
-
- /* In general, it tries to display the 'cleanest' representation of the
- * innards, choosing whether to display them inverted or not, regardless of
- * whether the class itself is to be inverted. However, there are some
- * cases where it can't try inverting, as what actually matches isn't known
- * until runtime, and hence the inversion isn't either. */
-
- bool inverting_allowed = ! force_as_is_display;
-
- int i;
- STRLEN orig_sv_cur = SvCUR(sv);
-
- SV* invlist; /* Inversion list we accumulate of code points that
- are unconditionally matched */
- SV* only_utf8 = NULL; /* Under /d, list of matches iff the target is
- UTF-8 */
- SV* not_utf8 = NULL; /* /d, list of matches iff the target isn't UTF-8
- */
- SV* posixes = NULL; /* Under /l, string of things like [:word:], \D */
- SV* only_utf8_locale = NULL; /* Under /l, list of matches if the locale
- is UTF-8 */
-
- SV* as_is_display; /* The output string when we take the inputs
- literally */
- SV* inverted_display; /* The output string when we invert the inputs */
-
- bool invert = cBOOL(flags & ANYOF_INVERT); /* Is the input to be inverted
- to match? */
- /* We are biased in favor of displaying things without them being inverted,
- * as that is generally easier to understand */
- const int bias = 5;
-
- PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS;
-
- /* Start off with whatever code points are passed in. (We clone, so we
- * don't change the caller's list) */
- if (nonbitmap_invlist) {
- assert(invlist_highest(nonbitmap_invlist) < NUM_ANYOF_CODE_POINTS);
- invlist = invlist_clone(nonbitmap_invlist, NULL);
- }
- else { /* Worst case size is every other code point is matched */
- invlist = _new_invlist(NUM_ANYOF_CODE_POINTS / 2);
- }
-
- if (flags) {
- if (OP(node) == ANYOFD) {
-
- /* This flag indicates that the code points below 0x100 in the
- * nonbitmap list are precisely the ones that match only when the
- * target is UTF-8 (they should all be non-ASCII). */
- if (flags & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)
- {
- _invlist_intersection(invlist, PL_UpperLatin1, &only_utf8);
- _invlist_subtract(invlist, only_utf8, &invlist);
- }
-
- /* And this flag for matching all non-ASCII 0xFF and below */
- if (flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)
- {
- not_utf8 = invlist_clone(PL_UpperLatin1, NULL);
- }
- }
- else if (OP(node) == ANYOFL || OP(node) == ANYOFPOSIXL) {
-
- /* If either of these flags are set, what matches isn't
- * determinable except during execution, so don't know enough here
- * to invert */
- if (flags & (ANYOFL_FOLD|ANYOF_MATCHES_POSIXL)) {
- inverting_allowed = FALSE;
- }
-
- /* What the posix classes match also varies at runtime, so these
- * will be output symbolically. */
- if (ANYOF_POSIXL_TEST_ANY_SET(node)) {
- int i;
-
- posixes = newSVpvs("");
- for (i = 0; i < ANYOF_POSIXL_MAX; i++) {
- if (ANYOF_POSIXL_TEST(node, i)) {
- sv_catpv(posixes, anyofs[i]);
- }
- }
- }
- }
- }
-
- /* Accumulate the bit map into the unconditional match list */
- if (bitmap) {
- for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
- if (BITMAP_TEST(bitmap, i)) {
- int start = i++;
- for (;
- i < NUM_ANYOF_CODE_POINTS && BITMAP_TEST(bitmap, i);
- i++)
- { /* empty */ }
- invlist = _add_range_to_invlist(invlist, start, i-1);
- }
- }
- }
-
- /* Make sure that the conditional match lists don't have anything in them
- * that match unconditionally; otherwise the output is quite confusing.
- * This could happen if the code that populates these misses some
- * duplication. */
- if (only_utf8) {
- _invlist_subtract(only_utf8, invlist, &only_utf8);
- }
- if (not_utf8) {
- _invlist_subtract(not_utf8, invlist, ¬_utf8);
- }
-
- if (only_utf8_locale_invlist) {
-
- /* Since this list is passed in, we have to make a copy before
- * modifying it */
- only_utf8_locale = invlist_clone(only_utf8_locale_invlist, NULL);
-
- _invlist_subtract(only_utf8_locale, invlist, &only_utf8_locale);
-
- /* And, it can get really weird for us to try outputting an inverted
- * form of this list when it has things above the bitmap, so don't even
- * try */
- if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
- inverting_allowed = FALSE;
- }
- }
-
- /* Calculate what the output would be if we take the input as-is */
- as_is_display = put_charclass_bitmap_innards_common(invlist,
- posixes,
- only_utf8,
- not_utf8,
- only_utf8_locale,
- invert);
-
- /* If have to take the output as-is, just do that */
- if (! inverting_allowed) {
- if (as_is_display) {
- sv_catsv(sv, as_is_display);
- SvREFCNT_dec_NN(as_is_display);
- }
- }
- else { /* But otherwise, create the output again on the inverted input, and
- use whichever version is shorter */
-
- int inverted_bias, as_is_bias;
-
- /* We will apply our bias to whichever of the results doesn't have
- * the '^' */
- if (invert) {
- invert = FALSE;
- as_is_bias = bias;
- inverted_bias = 0;
- }
- else {
- invert = TRUE;
- as_is_bias = 0;
- inverted_bias = bias;
- }
-
- /* Now invert each of the lists that contribute to the output,
- * excluding from the result things outside the possible range */
-
- /* For the unconditional inversion list, we have to add in all the
- * conditional code points, so that when inverted, they will be gone
- * from it */
- _invlist_union(only_utf8, invlist, &invlist);
- _invlist_union(not_utf8, invlist, &invlist);
- _invlist_union(only_utf8_locale, invlist, &invlist);
- _invlist_invert(invlist);
- _invlist_intersection(invlist, PL_InBitmap, &invlist);
-
- if (only_utf8) {
- _invlist_invert(only_utf8);
- _invlist_intersection(only_utf8, PL_UpperLatin1, &only_utf8);
- }
- else if (not_utf8) {
-
- /* If a code point matches iff the target string is not in UTF-8,
- * then complementing the result has it not match iff not in UTF-8,
- * which is the same thing as matching iff it is UTF-8. */
- only_utf8 = not_utf8;
- not_utf8 = NULL;
- }
-
- if (only_utf8_locale) {
- _invlist_invert(only_utf8_locale);
- _invlist_intersection(only_utf8_locale,
- PL_InBitmap,
- &only_utf8_locale);
- }
-
- inverted_display = put_charclass_bitmap_innards_common(
- invlist,
- posixes,
- only_utf8,
- not_utf8,
- only_utf8_locale, invert);
-
- /* Use the shortest representation, taking into account our bias
- * against showing it inverted */
- if ( inverted_display
- && ( ! as_is_display
- || ( SvCUR(inverted_display) + inverted_bias
- < SvCUR(as_is_display) + as_is_bias)))
- {
- sv_catsv(sv, inverted_display);
- }
- else if (as_is_display) {
- sv_catsv(sv, as_is_display);
- }
-
- SvREFCNT_dec(as_is_display);
- SvREFCNT_dec(inverted_display);
- }
-
- SvREFCNT_dec_NN(invlist);
- SvREFCNT_dec(only_utf8);
- SvREFCNT_dec(not_utf8);
- SvREFCNT_dec(posixes);
- SvREFCNT_dec(only_utf8_locale);
-
- return SvCUR(sv) > orig_sv_cur;
-}
-
-#define CLEAR_OPTSTART \
- if (optstart) STMT_START { \
- DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ \
- " (%" IVdf " nodes)\n", (IV)(node - optstart))); \
- optstart=NULL; \
- } STMT_END
-
-#define DUMPUNTIL(b,e) \
- CLEAR_OPTSTART; \
- node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
-
-STATIC const regnode *
-S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
- const regnode *last, const regnode *plast,
- SV* sv, I32 indent, U32 depth)
-{
- U8 op = PSEUDO; /* Arbitrary non-END op. */
- const regnode *next;
- const regnode *optstart= NULL;
-
- RXi_GET_DECL(r, ri);
- DECLARE_AND_GET_RE_DEBUG_FLAGS;
-
- PERL_ARGS_ASSERT_DUMPUNTIL;
-
-#ifdef DEBUG_DUMPUNTIL
- Perl_re_printf( aTHX_ "--- %d : %d - %d - %d\n", indent, node-start,
- last ? last-start : 0, plast ? plast-start : 0);
-#endif
-
- if (plast && plast < last)
- last= plast;
-
- while (PL_regkind[op] != END && (!last || node < last)) {
- assert(node);
- /* While that wasn't END last time... */
- NODE_ALIGN(node);
- op = OP(node);
- if (op == CLOSE || op == SRCLOSE || op == WHILEM)
- indent--;
- next = regnext((regnode *)node);
-
- /* Where, what. */
- if (OP(node) == OPTIMIZED) {
- if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
- optstart = node;
- else
- goto after_print;
- } else
- CLEAR_OPTSTART;
-
- regprop(r, sv, node, NULL, NULL);
- Perl_re_printf( aTHX_ "%4" IVdf ":%*s%s", (IV)(node - start),
- (int)(2*indent + 1), "", SvPVX_const(sv));
-
- if (OP(node) != OPTIMIZED) {
- if (next == NULL) /* Next ptr. */
- Perl_re_printf( aTHX_ " (0)");
- else if (PL_regkind[(U8)op] == BRANCH
- && PL_regkind[OP(next)] != BRANCH )
- Perl_re_printf( aTHX_ " (FAIL)");
- else
- Perl_re_printf( aTHX_ " (%" IVdf ")", (IV)(next - start));
- Perl_re_printf( aTHX_ "\n");
- }
-
- after_print:
- if (PL_regkind[(U8)op] == BRANCHJ) {
- assert(next);
- {
- const regnode *nnode = (OP(next) == LONGJMP
- ? regnext((regnode *)next)
- : next);
- if (last && nnode > last)
- nnode = last;
- DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
- }
- }
- else if (PL_regkind[(U8)op] == BRANCH) {
- assert(next);
- DUMPUNTIL(NEXTOPER(node), next);
- }
- else if ( PL_regkind[(U8)op] == TRIE ) {
- const regnode *this_trie = node;
- const char op = OP(node);
- const U32 n = ARG(node);
- const reg_ac_data * const ac = op>=AHOCORASICK ?
- (reg_ac_data *)ri->data->data[n] :
- NULL;
- const reg_trie_data * const trie =
- (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
-#ifdef DEBUGGING
- AV *const trie_words
- = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
-#endif
- const regnode *nextbranch= NULL;
- I32 word_idx;
- SvPVCLEAR(sv);
- for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
- SV ** const elem_ptr = av_fetch(trie_words, word_idx, 0);
-
- Perl_re_indentf( aTHX_ "%s ",
- indent+3,
- elem_ptr
- ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr),
- SvCUR(*elem_ptr), PL_dump_re_max_len,
- PL_colors[0], PL_colors[1],
- (SvUTF8(*elem_ptr)
- ? PERL_PV_ESCAPE_UNI
- : 0)
- | PERL_PV_PRETTY_ELLIPSES
- | PERL_PV_PRETTY_LTGT
- )
- : "???"
- );
- if (trie->jump) {
- U16 dist= trie->jump[word_idx+1];
- Perl_re_printf( aTHX_ "(%" UVuf ")\n",
- (UV)((dist ? this_trie + dist : next) - start));
- if (dist) {
- if (!nextbranch)
- nextbranch= this_trie + trie->jump[0];
- DUMPUNTIL(this_trie + dist, nextbranch);
- }
- if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
- nextbranch= regnext((regnode *)nextbranch);
- } else {
- Perl_re_printf( aTHX_ "\n");
- }
- }
- if (last && next > last)
- node= last;
- else
- node= next;
- }
- else if ( op == CURLY ) { /* "next" might be very big: optimizer */
- DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
- NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
- }
- else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
- assert(next);
- DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
- }
- else if ( op == PLUS || op == STAR) {
- DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
- }
- else if (PL_regkind[(U8)op] == EXACT || op == ANYOFHs) {
- /* Literal string, where present. */
- node += NODE_SZ_STR(node) - 1;
- node = NEXTOPER(node);
- }
- else {
- node = NEXTOPER(node);
- node += regarglen[(U8)op];
- }
- if (op == CURLYX || op == OPEN || op == SROPEN)
- indent++;
- }
- CLEAR_OPTSTART;
-#ifdef DEBUG_DUMPUNTIL
- Perl_re_printf( aTHX_ "--- %d\n", (int)indent);
-#endif
- return node;
-}
-
-#endif /* DEBUGGING */
-
#ifndef PERL_IN_XSUB_RE
# include "uni_keywords.h"
/* Set up the inversion list interpreter-level variables */
- PL_XPosix_ptrs[_CC_ASCII] = _new_invlist_C_array(uni_prop_ptrs[UNI_ASCII]);
- PL_XPosix_ptrs[_CC_ALPHANUMERIC] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXALNUM]);
- PL_XPosix_ptrs[_CC_ALPHA] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXALPHA]);
- PL_XPosix_ptrs[_CC_BLANK] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXBLANK]);
- PL_XPosix_ptrs[_CC_CASED] = _new_invlist_C_array(uni_prop_ptrs[UNI_CASED]);
- PL_XPosix_ptrs[_CC_CNTRL] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXCNTRL]);
- PL_XPosix_ptrs[_CC_DIGIT] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXDIGIT]);
- PL_XPosix_ptrs[_CC_GRAPH] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXGRAPH]);
- PL_XPosix_ptrs[_CC_LOWER] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXLOWER]);
- PL_XPosix_ptrs[_CC_PRINT] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXPRINT]);
- PL_XPosix_ptrs[_CC_PUNCT] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXPUNCT]);
- PL_XPosix_ptrs[_CC_SPACE] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXSPACE]);
- PL_XPosix_ptrs[_CC_UPPER] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXUPPER]);
- PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(uni_prop_ptrs[UNI_VERTSPACE]);
- PL_XPosix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXWORD]);
- PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXXDIGIT]);
-
- PL_Posix_ptrs[_CC_ASCII] = _new_invlist_C_array(uni_prop_ptrs[UNI_ASCII]);
- PL_Posix_ptrs[_CC_ALPHANUMERIC] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXALNUM]);
- PL_Posix_ptrs[_CC_ALPHA] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXALPHA]);
- PL_Posix_ptrs[_CC_BLANK] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXBLANK]);
- PL_Posix_ptrs[_CC_CASED] = PL_Posix_ptrs[_CC_ALPHA];
- PL_Posix_ptrs[_CC_CNTRL] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXCNTRL]);
- PL_Posix_ptrs[_CC_DIGIT] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXDIGIT]);
- PL_Posix_ptrs[_CC_GRAPH] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXGRAPH]);
- PL_Posix_ptrs[_CC_LOWER] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXLOWER]);
- PL_Posix_ptrs[_CC_PRINT] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXPRINT]);
- PL_Posix_ptrs[_CC_PUNCT] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXPUNCT]);
- PL_Posix_ptrs[_CC_SPACE] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXSPACE]);
- PL_Posix_ptrs[_CC_UPPER] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXUPPER]);
- PL_Posix_ptrs[_CC_VERTSPACE] = NULL;
- PL_Posix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXWORD]);
- PL_Posix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXXDIGIT]);
+ PL_XPosix_ptrs[CC_ASCII_] = _new_invlist_C_array(uni_prop_ptrs[UNI_ASCII]);
+ PL_XPosix_ptrs[CC_ALPHANUMERIC_] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXALNUM]);
+ PL_XPosix_ptrs[CC_ALPHA_] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXALPHA]);
+ PL_XPosix_ptrs[CC_BLANK_] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXBLANK]);
+ PL_XPosix_ptrs[CC_CASED_] = _new_invlist_C_array(uni_prop_ptrs[UNI_CASED]);
+ PL_XPosix_ptrs[CC_CNTRL_] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXCNTRL]);
+ PL_XPosix_ptrs[CC_DIGIT_] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXDIGIT]);
+ PL_XPosix_ptrs[CC_GRAPH_] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXGRAPH]);
+ PL_XPosix_ptrs[CC_LOWER_] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXLOWER]);
+ PL_XPosix_ptrs[CC_PRINT_] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXPRINT]);
+ PL_XPosix_ptrs[CC_PUNCT_] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXPUNCT]);
+ PL_XPosix_ptrs[CC_SPACE_] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXSPACE]);
+ PL_XPosix_ptrs[CC_UPPER_] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXUPPER]);
+ PL_XPosix_ptrs[CC_VERTSPACE_] = _new_invlist_C_array(uni_prop_ptrs[UNI_VERTSPACE]);
+ PL_XPosix_ptrs[CC_WORDCHAR_] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXWORD]);
+ PL_XPosix_ptrs[CC_XDIGIT_] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXXDIGIT]);
+
+ PL_Posix_ptrs[CC_ASCII_] = _new_invlist_C_array(uni_prop_ptrs[UNI_ASCII]);
+ PL_Posix_ptrs[CC_ALPHANUMERIC_] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXALNUM]);
+ PL_Posix_ptrs[CC_ALPHA_] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXALPHA]);
+ PL_Posix_ptrs[CC_BLANK_] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXBLANK]);
+ PL_Posix_ptrs[CC_CASED_] = PL_Posix_ptrs[CC_ALPHA_];
+ PL_Posix_ptrs[CC_CNTRL_] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXCNTRL]);
+ PL_Posix_ptrs[CC_DIGIT_] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXDIGIT]);
+ PL_Posix_ptrs[CC_GRAPH_] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXGRAPH]);
+ PL_Posix_ptrs[CC_LOWER_] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXLOWER]);
+ PL_Posix_ptrs[CC_PRINT_] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXPRINT]);
+ PL_Posix_ptrs[CC_PUNCT_] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXPUNCT]);
+ PL_Posix_ptrs[CC_SPACE_] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXSPACE]);
+ PL_Posix_ptrs[CC_UPPER_] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXUPPER]);
+ PL_Posix_ptrs[CC_VERTSPACE_] = NULL;
+ PL_Posix_ptrs[CC_WORDCHAR_] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXWORD]);
+ PL_Posix_ptrs[CC_XDIGIT_] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXXDIGIT]);
PL_GCB_invlist = _new_invlist_C_array(_Perl_GCB_invlist);
PL_SB_invlist = _new_invlist_C_array(_Perl_SB_invlist);
U32 flags = PMf_MULTILINE|PMf_WILDCARD;
U32 rx_flags;
- SV * subpattern_sv = sv_2mortal(newSVpvn(subpattern, len));
+ SV * subpattern_sv = newSVpvn_flags(subpattern, len, SVs_TEMP);
REGEXP * subpattern_re;
DECLARE_AND_GET_RE_DEBUG_FLAGS;
STATIC I32
S_execute_wildcard(pTHX_ REGEXP * const prog, char* stringarg, char *strend,
- char *strbeg, SSize_t minend, SV *screamer, U32 nosave)
+ char *strbeg, SSize_t minend, SV *screamer, U32 nosave)
{
I32 result;
DECLARE_AND_GET_RE_DEBUG_FLAGS;
* compile perl to know about them) */
bool is_nv_type = FALSE;
- unsigned int i, j = 0;
+ unsigned int i = 0, i_zero = 0, j = 0;
int equals_pos = -1; /* Where the '=' is found, or negative if none */
int slash_pos = -1; /* Where the '/' is found, or negative if none */
int table_index = 0; /* The entry number for this property in the table
} /* End of parsing through the lhs of the property name (or all of it if
no rhs) */
-# define STRLENs(s) (sizeof("" s "") - 1)
-
/* If there is a single package name 'utf8::', it is ambiguous. It could
* be for a user-defined property, or it could be a Unicode property, as
* all of them are considered to be for that package. For the purposes of
* parsing the rest of the property, strip it off */
if (non_pkg_begin == STRLENs("utf8::") && memBEGINPs(name, name_len, "utf8::")) {
- lookup_name += STRLENs("utf8::");
- j -= STRLENs("utf8::");
- equals_pos -= STRLENs("utf8::");
+ lookup_name += STRLENs("utf8::");
+ j -= STRLENs("utf8::");
+ equals_pos -= STRLENs("utf8::");
+ i_zero = STRLENs("utf8::"); /* When resetting 'i' to reparse
+ from the beginning, it has to be
+ set past what we're stripping
+ off */
stripped_utf8_pkg = TRUE;
}
&& name[i] != '+'
&& name[i] != '_'
&& name[i] != '{'
- /* A backslash means the real delimitter is the next character,
+ /* A backslash means the real delimiter is the next character,
* but it must be punctuation */
&& (name[i] != '\\' || (i < name_len && isPUNCT_A(name[i+1]))))
{
const char * const * prop_values;
bool escaped = 0;
- /* Backslash => delimitter is the character following. We
+ /* Backslash => delimiter is the character following. We
* already checked that it is punctuation */
if (open == '\\') {
open = name[i++];
}
this_string = newAV();
- av_push(this_string, newSVuv(cp));
+ av_push_simple(this_string, newSVuv(cp));
do {
cp = valid_utf8_to_uvchr((U8 *) remaining, &character_len);
- av_push(this_string, newSVuv(cp));
+ av_push_simple(this_string, newSVuv(cp));
remaining += character_len;
} while (remaining < SvEND(character));
- av_push(*strings, (SV *) this_string);
+ av_push_simple(*strings, (SV *) this_string);
}
return prop_definition;
break;
}
}
+
+ /* Turn nv=-0 into nv=0. These should be equivalent, but vary by
+ * underling libc implementation. */
+ if ( i == name_len - 1
+ && name[name_len-1] == '0'
+ && lookup_name[j-1] == '-')
+ {
+ j--;
+ }
}
}
else { /* No '=' */
/* We set the inputs back to 0 and the code below will reparse,
* using strict */
- i = j = 0;
+ i = i_zero;
+ j = 0;
}
}
* separates two digits */
if (cur == '_') {
if ( stricter
- && ( i == 0 || (int) i == equals_pos || i == name_len- 1
+ && ( i == i_zero || (int) i == equals_pos || i == name_len- 1
|| ! isDIGIT_A(name[i-1]) || ! isDIGIT_A(name[i+1])))
{
lookup_name[j++] = '_';
&& name[non_pkg_begin+0] == 'I'
&& (name[non_pkg_begin+1] == 'n' || name[non_pkg_begin+1] == 's'))
{
- /* Names that start with In have different characterstics than those
+ /* Names that start with In have different characteristics than those
* that start with Is */
if (name[non_pkg_begin+1] == 's') {
starts_with_Is = TRUE;
* We start by constructing the hash key name, consisting of the
* fully qualified subroutine name, preceded by the /i status, so
* that there is a key for /i and a different key for non-/i */
- key = newSVpvn(((to_fold) ? "1" : "0"), 1);
+ key = newSVpvn_flags(((to_fold) ? "1" : "0"), 1, SVs_TEMP);
fq_name = S_get_fq_name(aTHX_ name, name_len, is_utf8,
non_pkg_begin != 0);
sv_catsv(key, fq_name);
- sv_2mortal(key);
/* We only call the sub once throughout the life of the program
* (with the /i, non-/i exception noted above). That means the
}
/* Get the greatest common denominator using
- http://en.wikipedia.org/wiki/Euclidean_algorithm */
+ https://en.wikipedia.org/wiki/Euclidean_algorithm */
gcd = numerator;
trial = denominator;
while (trial != 0) {
if (table_index > MAX_UNI_KEYWORD_INDEX) {
Size_t warning_offset = table_index / MAX_UNI_KEYWORD_INDEX;
table_index %= MAX_UNI_KEYWORD_INDEX;
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED__UNICODE_PROPERTY_NAME),
"Use of '%.*s' in \\p{} or \\P{} is deprecated because: %s",
(int) name_len, name,
get_deprecated_property_msg(warning_offset));
COPHH * hinthash = (IN_PERL_COMPILETIME)
? CopHINTHASH_get(&PL_compiling)
: CopHINTHASH_get(PL_curcop);
- SV * pu_overrides = cophh_fetch_pv(hinthash, "private_use", 0, 0);
+ SV * pu_overrides = cophh_fetch_pv(hinthash, "private_use", 0, 0);
if (UNLIKELY(pu_overrides && SvPOK(pu_overrides))) {
/* Special _charnames entry point that returns the info this routine
* requires */
- call_sv(MUTABLE_SV(get_names_info), G_ARRAY);
+ call_sv(MUTABLE_SV(get_names_info), G_LIST);
SPAGAIN ;
* so we could match anywhere in that string. We have to rule out
* matching a code point line */
char * this_name_start = all_names_start
- + RX_OFFS(subpattern_re)->start;
+ + RX_OFFS_START(subpattern_re,0);
char * this_name_end = all_names_start
- + RX_OFFS(subpattern_re)->end;
+ + RX_OFFS_END(subpattern_re,0);
char * cp_start;
char * cp_end;
UV cp = 0; /* Silences some compilers */
}
is_multi = TRUE;
- av_push(this_string, newSVuv(cp));
+ av_push_simple(this_string, newSVuv(cp));
}
}
*strings = newAV();
}
- av_push(*strings, (SV *) this_string);
+ av_push_simple(*strings, (SV *) this_string);
}
else { /* Only a single code point */
*prop_definition = add_cp_to_invlist(*prop_definition, cp);
https://perl5.git.perl.org / perl5.git / blobdiff