diff options
Diffstat (limited to 'regcomp.c')
| -rw-r--r-- | regcomp.c | 10477 |
1 files changed, 102 insertions, 10375 deletions
@@ -31,29 +31,25 @@ * 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 * - * Copyright (c) 1986 by University of Toronto. - * Written by Henry Spencer. Not derived from licensed software. + * Copyright (c) 1986 by University of Toronto. + * Written by Henry Spencer. Not derived from licensed software. * - * Permission is granted to anyone to use this software for any - * purpose on any computer system, and to redistribute it freely, - * subject to the following restrictions: + * Permission is granted to anyone to use this software for any + * purpose on any computer system, and to redistribute it freely, + * subject to the following restrictions: * - * 1. The author is not responsible for the consequences of use of - * this software, no matter how awful, even if they arise - * from defects in it. + * 1. The author is not responsible for the consequences of use of + * this software, no matter how awful, even if they arise + * from defects in it. * - * 2. The origin of this software must not be misrepresented, either - * by explicit claim or by omission. + * 2. The origin of this software must not be misrepresented, either + * by explicit claim or by omission. * - * 3. Altered versions must be plainly marked as such, and must not - * be misrepresented as being the original software. + * 3. Altered versions must be plainly marked as such, and must not + * be misrepresented as being the original software. * * **** Alterations to Henry's code are... @@ -127,11 +123,16 @@ * 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; @@ -142,1349 +143,7 @@ EXTERN_C const struct regexp_engine wild_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 ? */ - -#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) - - -/***********************************************************************/ -/* UTILITY MACROS FOR ADVANCING OR SETTING THE PARSE "CURSOR" RExC_parse - * - * All of these macros depend on the above RExC_ accessor macros, which - * in turns depend on a variable pRExC_state being in scope where they - * are used. This is the standard regexp parser context variable which is - * passed into every non-trivial parse function in this file. - * - * Note that the UTF macro is itself a wrapper around RExC_utf8, so all - * of the macros which do not take an argument will operate on the - * pRExC_state structure *only*. - * - * Please do NOT modify RExC_parse without using these macros. In the - * future these macros will be extended for enhanced debugging and trace - * output during the parse process. - */ - -/* RExC_parse_incf(flag) - * - * Increment RExC_parse to point at the next codepoint, while doing - * the right thing depending on whether we are parsing UTF-8 strings - * or not. The 'flag' argument determines if content is UTF-8 or not, - * intended for cases where this is NOT governed by the UTF macro. - * - * Use RExC_parse_inc() if UTF-8ness is controlled by the UTF macro. - * - * WARNING: Does NOT take into account RExC_end; it is the callers - * responsibility to make sure there are enough octets left in - * RExC_parse to ensure that when processing UTF-8 we would not read - * past the end of the string. - */ -#define RExC_parse_incf(flag) STMT_START { \ - RExC_parse += (flag) ? UTF8SKIP(RExC_parse) : 1; \ -} STMT_END - -/* RExC_parse_inc_safef(flag) - * - * Safely increment RExC_parse to point at the next codepoint, - * doing the right thing depending on whether we are parsing - * UTF-8 strings or not and NOT reading past the end of the buffer. - * The 'flag' argument determines if content is UTF-8 or not, - * intended for cases where this is NOT governed by the UTF macro. - * - * Use RExC_parse_safe() if UTF-8ness is controlled by the UTF macro. - * - * NOTE: Will NOT read past RExC_end when content is UTF-8. - */ -#define RExC_parse_inc_safef(flag) STMT_START { \ - RExC_parse += (flag) ? UTF8_SAFE_SKIP(RExC_parse,RExC_end) : 1; \ -} STMT_END - -/* RExC_parse_inc() - * - * Increment RExC_parse to point at the next codepoint, - * doing the right thing depending on whether we are parsing - * UTF-8 strings or not. - * - * WARNING: Does NOT take into account RExC_end, it is the callers - * responsibility to make sure there are enough octets left in - * RExC_parse to ensure that when processing UTF-8 we would not read - * past the end of the string. - * - * NOTE: whether we are parsing UTF-8 or not is determined by the - * UTF macro which is defined as cBOOL(RExC_parse_utf8), thus this - * macro operates on the pRExC_state structure only. - */ -#define RExC_parse_inc() RExC_parse_incf(UTF) - -/* RExC_parse_inc_safe() - * - * Safely increment RExC_parse to point at the next codepoint, - * doing the right thing depending on whether we are parsing - * UTF-8 strings or not and NOT reading past the end of the buffer. - * - * NOTE: whether we are parsing UTF-8 or not is determined by the - * UTF macro which is defined as cBOOL(RExC_parse_utf8), thus this - * macro operates on the pRExC_state structure only. - */ -#define RExC_parse_inc_safe() RExC_parse_inc_safef(UTF) - -/* RExC_parse_inc_utf8() - * - * Increment RExC_parse to point at the next utf8 codepoint, - * assumes content is UTF-8. - * - * WARNING: Does NOT take into account RExC_end; it is the callers - * responsibility to make sure there are enough octets left in RExC_parse - * to ensure that when processing UTF-8 we would not read past the end - * of the string. - */ -#define RExC_parse_inc_utf8() STMT_START { \ - RExC_parse += UTF8SKIP(RExC_parse); \ -} STMT_END - -/* RExC_parse_inc_if_char() - * - * Increment RExC_parse to point at the next codepoint, if and only - * if the current parse point is NOT a NULL, while doing the right thing - * depending on whether we are parsing UTF-8 strings or not. - * - * WARNING: Does NOT take into account RExC_end, it is the callers - * responsibility to make sure there are enough octets left in RExC_parse - * to ensure that when processing UTF-8 we would not read past the end - * of the string. - * - * NOTE: whether we are parsing UTF-8 or not is determined by the - * UTF macro which is defined as cBOOL(RExC_parse_utf8), thus this - * macro operates on the pRExC_state structure only. - */ -#define RExC_parse_inc_if_char() STMT_START { \ - RExC_parse += SKIP_IF_CHAR(RExC_parse,RExC_end); \ -} STMT_END - -/* RExC_parse_inc_by(n_octets) - * - * Increment the parse cursor by the number of octets specified by - * the 'n_octets' argument. - * - * NOTE: Does NOT check ANY constraints. It is the callers responsibility - * that this will not move past the end of the string, or leave the - * pointer in the middle of a UTF-8 sequence. - * - * Typically used to advanced past previously analyzed content. - */ -#define RExC_parse_inc_by(n_octets) STMT_START { \ - RExC_parse += (n_octets); \ -} STMT_END - -/* RExC_parse_set(to_ptr) - * - * Sets the RExC_parse pointer to the pointer specified by the 'to' - * argument. No validation whatsoever is performed on the to pointer. - */ -#define RExC_parse_set(to_ptr) STMT_START { \ - RExC_parse = (to_ptr); \ -} STMT_END - -/**********************************************************************/ - -/* 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. - */ -#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 - -/* About the term "restudy" and the var "restudied" and the defines - * "SCF_TRIE_RESTUDY" and "SCF_TRIE_DOING_RESTUDY": All of these relate to - * doing multiple study_chunk() calls over the same set of opcodes for* the - * purpose of enhanced TRIE optimizations. - * - * Specifically, when TRIE_STUDY_OPT is defined, and it is defined in normal - * builds, (see above), during compilation SCF_TRIE_RESTUDY may be enabled - * which then causes the Perl_re_op_compile() to then call the optimizer - * S_study_chunk() a second time to perform additional optimizations, - * including the aho_corasick startclass optimization. - * This additional pass will only happen once, which is managed by the - * 'restudied' variable in Perl_re_op_compile(). - * - * When this second pass is under way the flags passed into study_chunk() will - * include SCF_TRIE_DOING_RESTUDY and this flag is and must be cascaded down - * to any recursive calls to S_study_chunk(). - * - * IMPORTANT: Any logic in study_chunk() that emits warnings should check that - * the SCF_TRIE_DOING_RESTUDY flag is NOT set in 'flags', or the warning may - * be produced twice. - * - * See commit 07be1b83a6b2d24b492356181ddf70e1c7917ae3 and - * 688e03912e3bff2d2419c457d8b0e1bab3eb7112 for more details. - */ - - -#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 **last_close_opp; /* pointer to pointer to last CLOSE regop - seen. DO NOT DEREFERENCE the regnode - pointer - the op may have been optimized - away */ - 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, 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 /* Need to do restudy in study_chunk()? - Search for "restudy" in this file - to find a detailed explanation.*/ -#define SCF_SEEN_ACCEPT 0x8000 -#define SCF_TRIE_DOING_RESTUDY 0x10000 /* Are we in restudy right now? - Search for "restudy" in this file - to find a detailed explanation. */ -#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 - -#define ckWARNexperimental_with_arg(loc, class, m, arg) \ - 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, \ - arg, 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) (__ASSERT_((node) >= RExC_emit_start) \ - (SSize_t) ((node) - RExC_emit_start)) - -#define ProgLen(ri) ri->proglen -#define SetProgLen(ri,x) ri->proglen = x - -#if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS -#define EXPERIMENTAL_INPLACESCAN -#endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/ - -STATIC void -S_populate_bitmap_from_invlist(pTHX_ SV * invlist, const UV offset, const U8 * bitmap, const Size_t len) -{ - PERL_ARGS_ASSERT_POPULATE_BITMAP_FROM_INVLIST; - - /* As the name says. The zeroth bit corresponds to the code point given by - * 'offset' */ - - UV start, end; - - Zero(bitmap, len, U8); - - invlist_iterinit(invlist); - while (invlist_iternext(invlist, &start, &end)) { - assert(start >= offset); - - for (UV i = start; i <= end; i++) { - UV adjusted = i - offset; - - BITMAP_BYTE(bitmap, adjusted) |= BITMAP_BIT(adjusted); - } - } - invlist_iterfinish(invlist); -} - -STATIC void -S_populate_invlist_from_bitmap(pTHX_ const U8 * bitmap, const Size_t bitmap_len, SV ** invlist, const UV offset) -{ - PERL_ARGS_ASSERT_POPULATE_INVLIST_FROM_BITMAP; - - /* As the name says. The zeroth bit corresponds to the code point given by - * 'offset' */ - - Size_t i; - - for (i = 0; i < bitmap_len; i++) { - if (BITMAP_TEST(bitmap, i)) { - int start = i++; - - /* Save a little work by adding a range all at once instead of bit - * by bit */ - while (i < bitmap_len && BITMAP_TEST(bitmap, i)) { - i++; - } - - *invlist = _add_range_to_invlist(*invlist, - start + offset, - i + offset - 1); - } - } -} - -#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, - SSize_t min, SSize_t stopmin, SSize_t delta) -{ - DECLARE_AND_GET_RE_DEBUG_FLAGS; - - DEBUG_OPTIMISE_MORE_r({ - if (!data) - return; - Perl_re_indentf(aTHX_ "%s: M/S/D: %" IVdf "/%" IVdf "/%" IVdf " Pos:%" IVdf "/%" IVdf " Flags: 0x%" UVXf, - depth, - where, - min, stopmin, delta, - (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, min, stopmin, delta) \ - S_debug_studydata(aTHX_ where, data, depth, is_inf, min, stopmin, delta) - -# 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, min, stopmin, delta) NOOP -# define DEBUG_PEEP(str, scan, depth, flags) NOOP -#endif - +#include "regcomp_internal.h" /* ========================================================= * BEGIN edit_distance stuff. @@ -1631,5313 +290,16 @@ S_edit_distance(const UV* src, /* 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) -{ - 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; - - 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 - : (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; - } - - 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; - } - } - data->last_end = -1; - data->flags &= ~SF_BEFORE_EOL; - DEBUG_STUDYDATA("commit", data, 0, is_inf, -1, -1, -1); -} - -/* 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) -{ - /* 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 */ -} - -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 = 0, end = 0; /* Initialize due to messages from dumb compiler */ - bool ret; - - PERL_ARGS_ASSERT_SSC_IS_ANYTHING; - - assert(is_ANYOF_SYNTHETIC(ssc)); - - if (! (ANYOF_FLAGS(ssc) & SSC_MATCHES_EMPTY_STRING)) { - return FALSE; - } - - /* 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; - - invlist_iterfinish(ssc->invlist); - - 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) -{ - /* 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_MATCHES_ALL_OUTSIDE_BITMAP_VALUE); - 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); - } - else { - ANYOF_POSIXL_ZERO(ssc); - } -} - -STATIC int -S_ssc_is_cp_posixl_init(const RExC_state_t *pRExC_state, - const regnode_ssc *ssc) -{ - /* 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) */ - - UV start = 0, end = 0; /* Initialize due to messages from dumb compiler */ - bool ret; - - PERL_ARGS_ASSERT_SSC_IS_CP_POSIXL_INIT; - - assert(is_ANYOF_SYNTHETIC(ssc)); - - invlist_iterinit(ssc->invlist); - ret = invlist_iternext(ssc->invlist, &start, &end) - && start == 0 - && end == UV_MAX; - - invlist_iterfinish(ssc->invlist); - - if (! ret) { - return FALSE; - } - - if (RExC_contains_locale && ! ANYOF_POSIXL_SSC_TEST_ALL_SET(ssc)) { - return FALSE; - } - - return TRUE; -} - -#define INVLIST_INDEX 0 -#define ONLY_LOCALE_MATCHES_INDEX 1 -#define DEFERRED_USER_DEFINED_INDEX 2 - -STATIC SV* -S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state, - const regnode_charclass* const node) -{ - /* Returns a mortal inversion list defining which code points are matched - * by 'node', which is of ANYOF-ish type . 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; - bool new_node_has_latin1 = FALSE; - const U8 flags = (REGNODE_TYPE(OP(node)) == ANYOF) - ? ANYOF_FLAGS(node) - : 0; - - PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC; - - /* Look at the data structure created by S_set_ANYOF_arg() */ - if (ANYOF_MATCHES_ALL_OUTSIDE_BITMAP(node)) { - invlist = sv_2mortal(_new_invlist(1)); - invlist = _add_range_to_invlist(invlist, NUM_ANYOF_CODE_POINTS, UV_MAX); - } - else if (ANYOF_HAS_AUX(node)) { - const U32 n = ARG(node); - SV * const rv = MUTABLE_SV(RExC_rxi->data->data[n]); - AV * const av = MUTABLE_AV(SvRV(rv)); - SV **const ary = AvARRAY(av); - - if (av_tindex_skip_len_mg(av) >= DEFERRED_USER_DEFINED_INDEX) { - - /* 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]) { - - /* Use the node's inversion list */ - invlist = sv_2mortal(invlist_clone(ary[INVLIST_INDEX], NULL)); - } - - /* 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 (! 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); - } - - /* Add in the points from the bit map */ - if (REGNODE_TYPE(OP(node)) == ANYOF){ - for (unsigned 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; - } - } - } - - /* 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 & ANYOFD_NON_UTF8_MATCHES_ALL_NON_ASCII__shared)) - { - _invlist_union(invlist, PL_UpperLatin1, &invlist); - } - - /* Similarly for these */ - if (ANYOF_MATCHES_ALL_OUTSIDE_BITMAP(node)) { - _invlist_union_complement_2nd(invlist, PL_InBitmap, &invlist); - } - - if (flags & ANYOF_INVERT) { - _invlist_invert(invlist); - } - else if (flags & ANYOFL_FOLD) { - if (new_node_has_latin1) { - - /* These folds are potential in Turkic locales */ - if (_invlist_contains_cp(invlist, 'i')) { - invlist = add_cp_to_invlist(invlist, - LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE); - } - if (_invlist_contains_cp(invlist, 'I')) { - invlist = add_cp_to_invlist(invlist, - LATIN_SMALL_LETTER_DOTLESS_I); - } - - /* 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); - } - else { - if (_invlist_contains_cp(invlist, LATIN_SMALL_LETTER_DOTLESS_I)) { - invlist = add_cp_to_invlist(invlist, 'I'); - } - if (_invlist_contains_cp(invlist, - LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE)) - { - invlist = add_cp_to_invlist(invlist, 'i'); - } - } - } - - /* 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; -} - -/* 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. */ - -STATIC void -S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc, - const regnode_charclass *and_with) -{ - /* 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 = (REGNODE_TYPE(OP(and_with)) == ANYOF) - ? ANYOF_FLAGS(and_with) - : 0; - 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_WARN_SUPER__shared; - } - } - 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 - |ANYOFD_NON_UTF8_MATCHES_ALL_NON_ASCII__shared - |ANYOF_HAS_EXTRA_RUNTIME_MATCHES); - if (and_with_flags & ANYOFL_UTF8_LOCALE_REQD) { - anded_flags &= ANYOF_HAS_EXTRA_RUNTIME_MATCHES; - } - } - } - - 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) - * */ - - 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); - } - } -} - -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. */ - - SV* ored_cp_list; - U8 ored_flags; - U8 or_with_flags = (REGNODE_TYPE(OP(or_with)) == ANYOF) - ? ANYOF_FLAGS(or_with) - : 0; - - PERL_ARGS_ASSERT_SSC_OR; - - assert(is_ANYOF_SYNTHETIC(ssc)); - - /* '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 & ( ANYOFD_NON_UTF8_MATCHES_ALL_NON_ASCII__shared - |ANYOF_HAS_EXTRA_RUNTIME_MATCHES); - if (or_with_flags & ANYOFL_UTF8_LOCALE_REQD) { - ored_flags |= ANYOF_HAS_EXTRA_RUNTIME_MATCHES; - } - } - } - - 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 ((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); - } - } - } - } - - ssc_union(ssc, - ored_cp_list, - FALSE /* Already has been inverted */ - ); -} - -STATIC void -S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, const bool invert2nd) -{ - PERL_ARGS_ASSERT_SSC_UNION; - - 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 - |ANYOFD_NON_UTF8_MATCHES_ALL_NON_ASCII__shared - |ANYOF_HAS_EXTRA_RUNTIME_MATCHES))); - - populate_anyof_bitmap_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_simple( 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_simple( 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_simple( 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_simple(revcharmap, zlopp); \ - } else { \ - char ooooff = (char)val; \ - av_push_simple(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_simple( 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, REGNODE_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 = REGNODE_AFTER( 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 = REGNODE_AFTER( 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 = REGNODE_AFTER( 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= REGNODE_AFTER(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 = REGNODE_AFTER( 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= REGNODE_AFTER(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; - char *str=NULL; - -#ifdef DEBUGGING - regnode *optimize = NULL; -#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); - /* whole branch chain */ - } - /* 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_simple( 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_simple( 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_simple( 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 = REGNODE_AFTER(convert); - assert( n - convert <= U16_MAX ); - NEXT_OFF(convert) = n - 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 - ) { - U32 word = trie->wordcount; - while (word--) { - SV ** const tmp = av_fetch_simple( 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 - + REGNODE_ARG_LEN( 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) { - /* - Try to clean up some of the debris left after the - optimisation. - */ - while( optimize < jumper ) { - OP( optimize ) = OPTIMIZED; - optimize++; - } - }); - } /* 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 preceding 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 = REGNODE_AFTER_varies(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(REGNODE_TYPE(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 - && ( REGNODE_TYPE(OP(n)) == NOTHING - || (stringok && REGNODE_TYPE(OP(n)) == EXACT)) - && NEXT_OFF(n) - && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) - { - - if (OP(n) == TAIL || n > next) - stringok = 0; - if (REGNODE_TYPE(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 = REGNODE_AFTER_varies(n); - NEXT_OFF(scan) += NEXT_OFF(n); - assert( ( STR_LEN(scan) + STR_LEN(n) ) < 256 ); - setSTR_LEN(scan, (U8)(STR_LEN(scan) + STR_LEN(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 (REGNODE_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 = REGNODE_AFTER_varies(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 = (REGNODE_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 = (REGNODE_OFF_BY_ARG(OP(node)) ? ARG(node) : NEXT_OFF(node)); - int noff; - regnode *n = node; - - /* Skip NOTHING and LONGJMP. */ - while ( - (n = regnext(n)) - && ( - (REGNODE_TYPE(OP(n)) == NOTHING && (noff = NEXT_OFF(n))) - || ((OP(n) == LONGJMP) && (noff = ARG(n))) - ) - && off + noff < max - ) { - off += noff; - } - if (REGNODE_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, /* Start here (read-write). */ - SSize_t *minlenp, /* used for the minlen of substrings? */ - SSize_t *deltap, /* Write maxlen-minlen here. */ - regnode *last, /* Stop before this one. */ - scan_data_t *data, /* string data about the pattern */ - I32 stopparen, /* treat CLOSE-N as END, see GOSUB */ - U32 recursed_depth, /* how deep have we recursed via GOSUB */ - regnode_ssc *and_withp, /* Valid if flags & SCF_DO_STCLASS_OR */ - U32 flags, /* flags controlling this call, see SCF_ flags */ - U32 depth, /* how deep have we recursed period */ - bool was_mutate_ok /* TRUE if in-place optimizations are allowed. - FALSE only if the caller (recursively) was - prohibited from modifying the regops, because - a higher caller is holding a ptr to them. */ -) -{ - /* vars about the regnodes we are working with */ - regnode *scan = *scanp; /* the current opcode we are inspecting */ - regnode *next = NULL; /* the next opcode beyond scan, tmp var */ - regnode *first_non_open = scan; /* FIXME: should this init to NULL? - the first non open regop, if the init - val IS an OPEN then we will skip past - it just after the var decls section */ - I32 code = 0; /* temp var used to hold the optype of a regop */ - - /* vars about the min and max length of the pattern */ - SSize_t min = 0; /* min length of this part of the pattern */ - SSize_t stopmin = OPTIMIZE_INFTY; /* min length accounting for ACCEPT - this is adjusted down if we find - an ACCEPT */ - SSize_t delta = 0; /* difference between min and max length - (not accounting for stopmin) */ - - /* vars about capture buffers in the pattern */ - I32 pars = 0; /* count of OPEN opcodes */ - I32 is_par = OP(scan) == OPEN ? PARNO(scan) : 0; /* is this op an OPEN? */ - - /* vars about whether this pattern contains something that can match - * infinitely long strings, eg, X* or X+ */ - int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF); - int is_inf_internal = 0; /* The studied chunk is infinite */ - - /* scan_data_t (struct) is used to hold information about the substrings - * and start class we have extracted from the string */ - scan_data_t data_fake; /* temp var used for recursing in some cases */ - - SV *re_trie_maxbuff = NULL; /* temp var used to hold whether we can do - trie optimizations */ - - scan_frame *frame = NULL; /* used as part of fake recursion */ - - 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, min, stopmin, delta); - 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 (REGNODE_TYPE(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; - regnode *fake_last_close_op = NULL; - U32 f = SCF_IN_DEFINE | (flags & SCF_TRIE_DOING_RESTUDY); - - 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; - data_fake.last_close_opp= &fake_last_close_op; - minlen = *minlenp; - next = regnext(scan); - scan = REGNODE_AFTER_type(scan,tregnode_IFTHEN); - 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_last_close = 0; - regnode *fake_last_close_op = NULL; - U32 f = (flags & SCF_TRIE_DOING_RESTUDY); - 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; - data_fake.last_close_opp = data->last_close_opp; - } - else { - data_fake.last_closep = &fake_last_close; - data_fake.last_close_opp = &fake_last_close_op; - } - - data_fake.pos_delta = delta; - next = regnext(scan); - - scan = REGNODE_AFTER_opcode(scan, code); - - 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); - DEBUG_STUDYDATA("end BRANCH", data, depth, is_inf, min, stopmin, delta); - } - 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; - } - } - DEBUG_STUDYDATA("pre TRIE", data, depth, is_inf, min, stopmin, delta); - - 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 = REGNODE_AFTER( 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), - REGNODE_NAME(trietype), REGNODE_NAME(noper_trietype), REGNODE_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), - REGNODE_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 */ - DEBUG_STUDYDATA("after TRIE", data, depth, is_inf, min, stopmin, delta); - } - else - scan = REGNODE_AFTER_opcode(scan,code); - 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, min, stopmin, delta); - PAREN_SET(recursed_depth, paren); - my_recursed_depth= recursed_depth + 1; - } else { - DEBUG_STUDYDATA("gosub-inf", data, depth, is_inf, min, stopmin, delta); - /* 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, min, stopmin, delta); - 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 (REGNODE_TYPE(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; - DEBUG_STUDYDATA("end EXACT", data, depth, is_inf, min, stopmin, delta); - } - else if (REGNODE_TYPE(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. - * Search for "restudy" in this file to find - * a comment with details. */ - 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); - if ((SSize_t)min_subtract < OPTIMIZE_INFTY - && delta < OPTIMIZE_INFTY - (SSize_t)min_subtract - ) { - delta += min_subtract; - } else { - delta = OPTIMIZE_INFTY; - } - if (flags & SCF_DO_SUBSTR) { - data->pos_min += charlen - min_subtract; - if (data->pos_min < 0) { - data->pos_min = 0; - } - if ((SSize_t)min_subtract < OPTIMIZE_INFTY - && data->pos_delta < OPTIMIZE_INFTY - (SSize_t)min_subtract - ) { - data->pos_delta += min_subtract; - } else { - data->pos_delta = OPTIMIZE_INFTY; - } - 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); - } - DEBUG_STUDYDATA("end EXACTish", data, depth, is_inf, min, stopmin, delta); - } - else if (REGNODE_VARIES(OP(scan))) { - SSize_t mincount, maxcount, minnext, deltanext, pos_before = 0; - I32 fl = 0; - U32 f = flags; - regnode * const oscan = scan; - regnode_ssc this_class; - regnode_ssc *oclass = NULL; - I32 next_is_eval = 0; - - switch (REGNODE_TYPE(OP(scan))) { - case WHILEM: /* End of (?:...)* . */ - scan = REGNODE_AFTER(scan); - goto finish; - case PLUS: - if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) { - next = REGNODE_AFTER(scan); - if ( ( REGNODE_TYPE(OP(next)) == EXACT - && ! isEXACTFish(OP(next))) - || (flags & SCF_DO_STCLASS)) - { - mincount = 1; - maxcount = REG_INFTY; - next = regnext(scan); - scan = REGNODE_AFTER(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 = REGNODE_AFTER(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 = REGNODE_AFTER(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 = REGNODE_AFTER(scan); - 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 (data && data->flags & SCF_SEEN_ACCEPT) { - if (mincount > 1) - mincount = 1; - } - - 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; - } - - if (data && data->flags & SCF_SEEN_ACCEPT) { - if (flags & SCF_DO_SUBSTR) { - scan_commit(pRExC_state, data, minlenp, is_inf); - flags &= ~SCF_DO_SUBSTR; - } - if (stopmin > min) - stopmin = min; - DEBUG_STUDYDATA("after-whilem accept", data, depth, is_inf, min, stopmin, delta); - } - /* 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 = REGNODE_AFTER_type(oscan, tregnode_CURLYX); - regnode * const nxt1 = nxt; -#ifdef DEBUGGING - regnode *nxt2; -#endif - - /* Skip open. */ - nxt = regnext(nxt); - if (!REGNODE_SIMPLE(OP(nxt)) - && !(REGNODE_TYPE(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[PARNO(nxt1)] = REGNODE_OFFSET(oscan); - - /*close->while*/ - RExC_close_parens[PARNO(nxt1)] = REGNODE_OFFSET(nxt) + 2; - } - /* Now we know that nxt2 is the only contents: */ - oscan->flags = (U8)PARNO(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 = REGNODE_AFTER_type(oscan, tregnode_CURLYX); /* 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. */ - /* note that we have changed the type of oscan to CURLYM here */ - regnode *nxt1 = REGNODE_AFTER_type(oscan, tregnode_CURLYM); /* OPEN*/ - - oscan->flags = (U8)PARNO(nxt); - if (RExC_open_parens) { - /*open->CURLYM*/ - RExC_open_parens[PARNO(nxt1)] = REGNODE_OFFSET(oscan); - - /*close->NOTHING*/ - RExC_close_parens[PARNO(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 (REGNODE_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(REGNODE_BEFORE(nxt)) == NOTHING) /* LONGJMP */ - nxt += ARG(nxt); - nxt = REGNODE_BEFORE(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 - " data->pos_delta=%" UVuf "\n", - (UV)counted, (UV)deltanext, (UV)OPTIMIZE_INFTY, (UV)minnext, - (UV)maxcount, (UV)mincount, (UV)data->pos_delta); - 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 - || data->pos_delta == 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 ANYOFHbbm: - { - SV* cp_list = get_ANYOFHbbm_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 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 (REGNODE_TYPE(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 ( REGNODE_TYPE(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. - */ - - bool is_positive = OP(scan) == IFMATCH ? 1 : 0; - SSize_t deltanext, minnext; - SSize_t fake_last_close = 0; - regnode *fake_last_close_op = NULL; - regnode *cur_last_close_op; - regnode *nscan; - regnode_ssc intrnl; - U32 f = (flags & SCF_TRIE_DOING_RESTUDY); - - 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; - data_fake.last_close_opp = data->last_close_opp; - } - else { - data_fake.last_closep = &fake_last_close; - data_fake.last_close_opp = &fake_last_close_op; - } - - /* remember the last_close_op we saw so we can see if - * we are dealing with variable length lookbehind that - * contains capturing buffers, which are considered - * experimental */ - cur_last_close_op= *(data_fake.last_close_opp); - - 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 = REGNODE_AFTER(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; - if ( - /* See a CLOSE op inside this lookbehind? */ - cur_last_close_op != *(data_fake.last_close_opp) - /* and not doing restudy. see: restudied */ - && !(flags & SCF_TRIE_DOING_RESTUDY) - ) { - /* this is positive variable length lookbehind with - * capture buffers inside of it */ - ckWARNexperimental_with_arg(RExC_parse, - WARN_EXPERIMENTAL__VLB, - "Variable length %s lookbehind with capturing is experimental", - is_positive ? "positive" : "negative"); - } - } - 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; - } - } - DEBUG_STUDYDATA("end LOOKAROUND", data, depth, is_inf, min, stopmin, delta); - } -#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_last_close = 0; - regnode *last_close_op = NULL; - regnode *nscan; - regnode_ssc intrnl; - U32 f = (flags & SCF_TRIE_DOING_RESTUDY); - /* 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_last_close; - data_fake.last_close_opp = &fake_last_close_opp; - } - 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 = REGNODE_AFTER(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)PARNO(scan)) - pars++; - } - else if (OP(scan) == CLOSE) { - if (stopparen == (I32)PARNO(scan)) { - break; - } - if ((I32)PARNO(scan) == is_par) { - next = regnext(scan); - - if ( next && (OP(next) != WHILEM) && next < last) - is_par = 0; /* Disable optimization */ - } - if (data) { - *(data->last_closep) = PARNO(scan); - *(data->last_close_opp) = scan; - } - } - else if (OP(scan) == EVAL) { - if (data) - data->flags |= SF_HAS_EVAL; - } - else if ( REGNODE_TYPE(OP(scan)) == ENDLIKE ) { - if (flags & SCF_DO_SUBSTR) { - scan_commit(pRExC_state, data, minlenp, is_inf); - flags &= ~SCF_DO_SUBSTR; - } - if (OP(scan)==ACCEPT) { - /* m{(*ACCEPT)x} does not have to start with 'x' */ - flags &= ~SCF_DO_STCLASS; - if (data) - data->flags |= SCF_SEEN_ACCEPT; - if (stopmin > min) - stopmin = min; - } - } - else if (OP(scan) == COMMIT) { - /* gh18770: m{abc(*COMMIT)xyz} must fail on "abc abcxyz", so we - * must not end up with "abcxyz" as a fixed substring else we'll - * skip straight to attempting to match at offset 4. - */ - if (flags & SCF_DO_SUBSTR) { - scan_commit(pRExC_state, data, minlenp, is_inf); - flags &= ~SCF_DO_SUBSTR; - } - } - 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 (REGNODE_TYPE(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; - U32 f = (flags & SCF_TRIE_DOING_RESTUDY); - SSize_t fake_last_close = 0; - regnode *fake_last_close_op = NULL; - 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; - data_fake.last_close_opp = data->last_close_opp; - } - else { - data_fake.last_closep = &fake_last_close; - data_fake.last_close_opp = &fake_last_close_op; - } - 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 && REGNODE_TYPE(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); - } - DEBUG_STUDYDATA("after JUMPTRIE", data, depth, is_inf, min, stopmin, delta); - } - 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; - DEBUG_STUDYDATA("after TRIE study", data, depth, is_inf, min, stopmin, delta); - continue; - } -#else - else if (REGNODE_TYPE(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; - } - -#endif /* old or new */ -#endif /* TRIE_STUDY_OPT */ - - else if (OP(scan) == REGEX_SET) { - Perl_croak(aTHX_ "panic: %s regnode should be resolved" - " before optimization", REGNODE_NAME(REGEX_SET)); - } - - /* 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, min, stopmin, delta); - 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, min, stopmin, delta); - - /* is this pattern infinite? Eg, consider /(a|b+)/ */ - if (is_inf_internal) - delta = OPTIMIZE_INFTY; - - /* deal with (*ACCEPT), Eg, consider /(foo(*ACCEPT)|bop)bar/ */ - if (min > stopmin) { - /* - At this point 'min' represents the minimum length string we can - match while *ignoring* the implication of ACCEPT, and 'delta' - represents the difference between the minimum length and maximum - length, and if the pattern matches an infinitely long string - (consider the + and * quantifiers) then we use the special delta - value of OPTIMIZE_INFTY to represent it. 'stopmin' is the - minimum length that can be matched *and* accepted. - - A pattern is accepted when matching was successful *and* - complete, and thus there is no further matching needing to be - done, no backtracking to occur, etc. Prior to the introduction - of ACCEPT the only opcode that signaled acceptance was the END - opcode, which is always the very last opcode in a regex program. - ACCEPT is thus conceptually an early successful return out of - the matching process. stopmin starts out as OPTIMIZE_INFTY to - represent "the entire pattern", and is ratched down to the - "current min" if necessary when an ACCEPT opcode is encountered. - - Thus stopmin might be smaller than min if we saw an (*ACCEPT), - and we now need to account for it in both min and delta. - Consider that in a pattern /AB/ normally the min length it can - match can be computed as min(A)+min(B). But (*ACCEPT) means - that it might be something else, not even neccesarily min(A) at - all. Consider - - A = /(foo(*ACCEPT)|x+)/ - B = /whop/ - AB = /(foo(*ACCEPT)|x+)whop/ - - The min for A is 1 for "x" and the delta for A is OPTIMIZE_INFTY - for "xxxxx...", its stopmin is 3 for "foo". The min for B is 4 for - "whop", and the delta of 0 as the pattern is of fixed length, the - stopmin would be OPTIMIZE_INFTY as it does not contain an ACCEPT. - When handling AB we expect to see a min of 5 for "xwhop", and a - delta of OPTIMIZE_INFTY for "xxxxx...whop", and a stopmin of 3 - for "foo". This should result in a final min of 3 for "foo", and - a final delta of OPTIMIZE_INFTY for "xxxxx...whop". - - In something like /(dude(*ACCEPT)|irk)x{3,7}/ we would have a - min of 6 for "irkxxx" and a delta of 4 for "irkxxxxxxx", and the - stop min would be 4 for "dude". This should result in a final - min of 4 for "dude", and a final delta of 6, for "irkxxxxxxx". - - When min is smaller than stopmin then we can ignore it. In the - fragment /(x{10,20}(*ACCEPT)|a)b+/, we would have a min of 2, - and a delta of OPTIMIZE_INFTY, and a stopmin of 10. Obviously - the ACCEPT doesn't reduce the minimum length of the string that - might be matched, nor affect the maximum length. - - In something like /foo(*ACCEPT)ba?r/ we would have a min of 5 - for "foobr", a delta of 1 for "foobar", and a stopmin of 3 for - "foo". We currently turn this into a min of 3 for "foo" and a - delta of 3 for "foobar" even though technically "foobar" isn't - possible. ACCEPT affects some aspects of the optimizer, like - length computations and mandatory substring optimizations, but - there are other optimzations this routine perfoms that are not - affected and this compromise simplifies implementation. - - It might be helpful to consider that this C function is called - recursively on the pattern in a bottom up fashion, and that the - min returned by a nested call may be marked as coming from an - ACCEPT, causing its callers to treat the returned min as a - stopmin as the recursion unwinds. Thus a single ACCEPT can affect - multiple calls into this function in different ways. - */ - - if (OPTIMIZE_INFTY - delta >= min - stopmin) - delta += min - stopmin; - else - delta = OPTIMIZE_INFTY; - min = stopmin; - } - - *scanp = scan; - *deltap = 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; - - - if (!(RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)) { - if (min > OPTIMIZE_INFTY - delta) - RExC_maxlen = OPTIMIZE_INFTY; - else if (RExC_maxlen < min + delta) - RExC_maxlen = min + delta; - } - DEBUG_STUDYDATA("post-fin", data, depth, is_inf, min, stopmin, delta); - return min; -} - /* 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. */ -STATIC U32 -S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n) +U32 +Perl_reg_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n) { U32 count = RExC_rxi->data ? RExC_rxi->data->count : 1; - PERL_ARGS_ASSERT_ADD_DATA; + PERL_ARGS_ASSERT_REG_ADD_DATA; /* 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 @@ -6958,9 +320,9 @@ S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n) /* 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 add_data is ALWAYS true, so we can tell it apart + * 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 add_data. This is particularly important with the new "single + * 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". */ @@ -7435,9 +797,9 @@ S_concat_pat(pTHX_ RExC_state_t * const pRExC_state, 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->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 @@ -7689,9 +1051,9 @@ S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state, assert(pat[src->start] == '('); assert(pat[src->end] == ')'); - dst->start = src->start; - dst->end = src->end; - dst->block = src->block; + 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++; @@ -8236,7 +1598,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, RExC_rx->intflags = 0; - RExC_flags = rx_flags; /* don't let top level (?i) bleed */ + 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 @@ -8423,11 +1785,11 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */ if (UTF) - SvUTF8_on(Rx); /* Unicode in it? */ + SvUTF8_on(Rx); /* Unicode in it? */ RExC_rxi->regstclass = NULL; - if (RExC_naughty >= TOO_NAUGHTY) /* Probably an expensive pattern. */ + if (RExC_naughty >= TOO_NAUGHTY) /* Probably an expensive pattern. */ RExC_rx->intflags |= PREGf_NAUGHTY; - scan = RExC_rxi->program + 1; /* First BRANCH. */ + 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 */ @@ -8487,7 +1849,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, /* Ignore EXACT as we deal with it later. */ if (REGNODE_TYPE(OP(first)) == EXACT) { if (! isEXACTFish(OP(first))) { - NOOP; /* Empty, get anchored substr later. */ + NOOP; /* Empty, get anchored substr later. */ } else RExC_rxi->regstclass = first; @@ -8581,7 +1943,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, ssc_init(pRExC_state, &ch_class); data.start_class = &ch_class; stclass_flag = SCF_DO_STCLASS_AND; - } else /* XXXX Check for BOUND? */ + } else /* XXXX Check for BOUND? */ stclass_flag = 0; data.last_closep = &last_close; data.last_close_opp = &last_close_op; @@ -8661,7 +2023,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, && ! (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")); + const U32 n = reg_add_data(pRExC_state, STR_WITH_LEN("f")); ssc_finalize(pRExC_state, data.start_class); @@ -8670,7 +2032,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, (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(). */ + 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_ @@ -8745,7 +2107,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, 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")); + const U32 n = reg_add_data(pRExC_state, STR_WITH_LEN("f")); ssc_finalize(pRExC_state, data.start_class); @@ -8754,7 +2116,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, (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(). */ + 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_ @@ -8860,7 +2222,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, #ifdef DEBUGGING if (RExC_paren_names) { - RExC_rxi->name_list_idx = add_data( pRExC_state, STR_WITH_LEN("a")); + 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 @@ -8916,426 +2278,6 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, } -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; - } -} - -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_alloc_x(SvIVX(sv_dat)) : 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 = newSV_type(SVt_NULL); - } - if (retarray) - av_push_simple(retarray, ret); - } - if (retarray) - return newRV_noinc(MUTABLE_SV(retarray)); - } - } - 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; - - 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); - 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)); - } - } - } - 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; - } - } - return &PL_sv_undef; -} - -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 (parno || flags & RXapif_ALL) { - av_push_simple(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 { - TAINT; - SvTAINT(sv); - } - } 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; - } - - /* 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; - - 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; - - 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; - } - } - 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; -} SV* Perl_reg_qr_package(pTHX_ REGEXP * const rx) @@ -9458,1730 +2400,6 @@ S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags) 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. - * - * 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. - * - * A range that contains just a single code point N will look like - * invlist[i] == N - * invlist[i+1] == N+1 - * - * 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. - * - * 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. - * - * More about inversion lists can be found in "Unicode Demystified" - * Chapter 13 by Richard Gillam, published by Addison-Wesley. - * - * 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. - * - * Some of the methods should always be private to the implementation, and some - * should eventually be made public */ - -/* The header definitions are in F<invlist_inline.h> */ - -#ifndef PERL_IN_XSUB_RE - -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 */ - - bool* offset = get_invlist_offset_addr(invlist); - UV* zero_addr = (UV *) SvPVX(invlist); - - PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT; - - /* Must be empty */ - assert(! _invlist_len(invlist)); - - *zero_addr = 0; - - /* 1^1 = 0; 1^0 = 1 */ - *offset = 1 ^ will_have_0; - return zero_addr + *offset; -} - -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); - -#ifndef NO_TAINT_SUPPORT - const int oldtainted = TAINT_get; -#endif - - 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; - - assert(is_invlist(invlist)); - - return &(((XINVLIST*) SvANY(invlist))->prev_index); -} - -PERL_STATIC_INLINE IV -S_invlist_previous_index(SV* const invlist) -{ - /* Returns cached index of previous search */ - - PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX; - - return *get_invlist_previous_index_addr(invlist); -} - -PERL_STATIC_INLINE void -S_invlist_set_previous_index(SV* const invlist, const IV index) -{ - /* Caches <index> for later retrieval */ - - PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX; - - assert(index == 0 || index < (int) _invlist_len(invlist)); - - *get_invlist_previous_index_addr(invlist) = index; -} - -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; - - assert(is_invlist(invlist)); - - SvPV_renew(invlist, MAX(min_size, SvCUR(invlist) + 1)); -} - -PERL_STATIC_INLINE void -S_invlist_clear(pTHX_ SV* invlist) /* Empty the inversion list */ -{ - PERL_ARGS_ASSERT_INVLIST_CLEAR; - - assert(is_invlist(invlist)); - - invlist_set_len(invlist, 0, 0); - invlist_trim(invlist); -} - -#endif /* ifndef PERL_IN_XSUB_RE */ - -PERL_STATIC_INLINE bool -S_invlist_is_iterating(const SV* const invlist) -{ - PERL_ARGS_ASSERT_INVLIST_IS_ITERATING; - - /* get_invlist_iter_addr()'s sv is non-const only because it returns a - * value that can be used to modify the invlist, it doesn't modify the - * invlist itself */ - return *(get_invlist_iter_addr((SV*)invlist)) < (STRLEN) UV_MAX; -} - -#ifndef PERL_IN_XSUB_RE - -PERL_STATIC_INLINE UV -S_invlist_max(const SV* const invlist) -{ - /* Returns the maximum number of elements storable in the inversion list's - * array, without having to realloc() */ - - PERL_ARGS_ASSERT_INVLIST_MAX; - - assert(is_invlist(invlist)); - - /* 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; -} - -STATIC void -S_initialize_invlist_guts(pTHX_ SV* invlist, const Size_t initial_size) -{ - PERL_ARGS_ASSERT_INITIALIZE_INVLIST_GUTS; - - /* 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); - - /* Force iterinit() to be used to get iteration to work */ - invlist_iterfinish(invlist); - - *get_invlist_previous_index_addr(invlist) = 0; - SvPOK_on(invlist); /* This allows B to extract the PV */ -} - -SV* -Perl__new_invlist(pTHX_ IV initial_size) -{ - - /* 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 */ - - SV* new_list; - - if (initial_size < 0) { - initial_size = 10; - } - - new_list = newSV_type(SVt_INVLIST); - initialize_invlist_guts(new_list, initial_size); - - return new_list; -} - -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. - */ - - SV* invlist = newSV_type(SVt_INVLIST); - - PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY; - - if (version_id != INVLIST_VERSION_ID) { - Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list"); - } - - /* 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)); - - SvLEN_set(invlist, 0); /* Means we own the contents, and the system - shouldn't touch it */ - - *(get_invlist_offset_addr(invlist)) = offset; - - /* 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); - - invlist_set_previous_index(invlist, 0); - - /* Initialize the iteration pointer. */ - invlist_iterfinish(invlist); - - SvREADONLY_on(invlist); - SvPOK_on(invlist); - - return invlist; -} - -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. */ - - UV* array; - UV max = invlist_max(invlist); - UV len = _invlist_len(invlist); - bool offset; - - PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST; - - if (len == 0) { /* Empty lists must be initialized */ - offset = start != 0; - array = _invlist_array_init(invlist, ! offset); - } - 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; - } - } - - /* Here the new range doesn't extend any existing set. Add it */ - - len += 2; /* Includes an element each for the start and end of range */ - - /* If wll overflow the existing space, extend, which may cause the array to - * be moved */ - if (max < len) { - invlist_extend(invlist, len); - - /* Have to set len here to avoid assert failure in invlist_array() */ - invlist_set_len(invlist, len, offset); - - array = invlist_array(invlist); - } - else { - invlist_set_len(invlist, len, offset); - } - - /* 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); - } -} - -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] - */ - - IV low = 0; - IV mid; - IV high = _invlist_len(invlist); - const IV highest_element = high - 1; - const UV* array; - - PERL_ARGS_ASSERT__INVLIST_SEARCH; - - /* If list is empty, return failure. */ - if (UNLIKELY(high == 0)) { - return -1; - } - - /* (We can't get the array unless we know the list is non-empty) */ - array = invlist_array(invlist); - - mid = invlist_previous_index(invlist); - assert(mid >=0); - if (UNLIKELY(mid > highest_element)) { - mid = highest_element; - } - - /* <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; - } - } - - /* 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; - } - } - - found_entry: - high--; - invlist_set_previous_index(invlist, high); - return high; -} - -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); - } - - return; - } - - /* 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 */ - - if (a == NULL || _invlist_len(a) == 0) { - if (*output == NULL) { - *output = _new_invlist(0); - } - else { - invlist_clear(*output); - } - return; - } - - /* 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; - } - - /* If the output is to overwrite 'a', we have a no-op, as it's - * already in 'a' */ - if (*output == a) { - return; - } - - /* Here, '*output' is to be overwritten by 'a' */ - u = invlist_clone(a, NULL); - invlist_replace_list_destroys_src(*output, u); - SvREFCNT_dec_NN(u); - - return; - } - - /* Here 'b' is not empty. See about 'a' */ - - if (a == NULL || ((len_a = _invlist_len(a)) == 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 */ - - SV ** dest = (*output == NULL) ? output : &u; - *dest = invlist_clone(b, NULL); - if (complement_b) { - _invlist_invert(*dest); - } - - if (dest == &u) { - invlist_replace_list_destroys_src(*output, u); - SvREFCNT_dec_NN(u); - } - - return; - } - - /* Here both lists exist and are non-empty */ - array_a = invlist_array(a); - array_b = invlist_array(b); - - /* 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) { - - /* 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 { - - /* 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++; - } - } - - /* 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--; - } - - /* 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); - } - 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); - } - 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); - } - - 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); - } - - 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 - */ - - 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; - } - - if (*i == NULL) { - *i = invlist_clone(a, NULL); - return; - } - - r = invlist_clone(a, NULL); - invlist_replace_list_destroys_src(*i, r); - SvREFCNT_dec_NN(r); - return; - } - - /* 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; - } - - invlist_clear(*i); - return; - } - - /* Here both lists exist and are non-empty */ - array_a = invlist_array(a); - array_b = invlist_array(b); - - /* 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) { - - /* 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 { - - /* 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++; - } - } - - /* 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--; - } - - } - - /* 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++; - } - - /* 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); - } - - 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); - } - - 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; - } - - /* Likewise, if the inversion list is currently empty */ - len = _invlist_len(invlist); - if (len == 0) { - _append_range_to_invlist(invlist, start, end); - return invlist; - } - - /* Starting here, we have to know the internals of the list */ - array = invlist_array(invlist); - - /* If the new range ends higher than the current highest ... */ - cur_highest = invlist_highest(invlist); - if (end > cur_highest) { - - /* If the whole range is higher, we can just append it */ - if (start > cur_highest) { - _append_range_to_invlist(invlist, start, end); - return invlist; - } - - /* 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; - } - else { - i_e = len - 2; - } - } - - /* We have dealt with appending, now see about prepending. If the new - * range starts lower than the current lowest ... */ - if (start < array[0]) { - - /* 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; - - range_invlist = _new_invlist(2); - _append_range_to_invlist(range_invlist, start, end); - - _invlist_union(invlist, range_invlist, &invlist); - - SvREFCNT_dec_NN(range_invlist); - - 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; - } - - /* 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. */ - - if ( ! ELEMENT_RANGE_MATCHES_INVLIST(i_s)) { - - /* 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--; - } - - /* 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++; - } - 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; - } - - /* 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)) { - - /* 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 (i_s == i_e) { - - /* 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; - } - - /* Here, no part of the range is in the list. Must add it. It will - * occupy 2 more slots */ - splice_in_new_range: - - 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); - - /* 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; - } - - /* 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; - - invlist = add_cp_to_invlist(invlist, element0); - offset = *get_invlist_offset_addr(invlist); - - invlist_set_len(invlist, size, offset); - *other_elements_ptr = invlist_array(invlist) + 1; - return invlist; -} - -#endif - -#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 */ - - PERL_ARGS_ASSERT__INVLIST_INVERT; - - assert(! invlist_is_iterating(invlist)); - - /* The inverse of matching nothing is matching everything */ - if (_invlist_len(invlist) == 0) { - _append_range_to_invlist(invlist, 0, UV_MAX); - return; - } - - *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); - } - else { - sv_upgrade(new_invlist, SVt_INVLIST); - initialize_invlist_guts(new_invlist, nominal_length); - } - - *(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 - -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 */ - - UV len = _invlist_len(invlist); - UV *array; - - PERL_ARGS_ASSERT_INVLIST_LOWEST; - - if (len == 0) { - return 0; - } - - array = invlist_array(invlist); - - return array[0]; -} - -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(""); - } - - 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 (SvCUR(output) && ! traditional_style) {/* Get rid of trailing blank */ - SvCUR_set(output, SvCUR(output) - 1); - } - - return output; -} - -#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; - } -} - -#endif - -#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 */ - - const UV len_a = _invlist_len(a); - UV len_b = _invlist_len(b); - - const UV* array_a = NULL; - const UV* array_b = NULL; - - PERL_ARGS_ASSERT__INVLISTEQ; - - /* 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); - } - - /* If are to compare 'a' with the complement of b, set it - * up so are looking at b's complement. */ - if (complement_b) { - - /* 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) { - - /* 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 */ - - array_b++; - len_b--; - } - 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++; - } - } - - 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, 'I' and - * 'i' can match U+130 and U+131 */ - if (OP(node) == EXACTFL) { - _invlist_union(invlist, PL_Latin1, &invlist); - if (isALPHA_FOLD_EQ(uc, '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 { - /* 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); - } - } - } - 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); - } - - if (OP(node) == EXACTFL) { - - /* 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 - -/* End of inversion list object */ STATIC void S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state) @@ -11451,12 +2669,6 @@ S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state) * 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, @@ -11484,7 +2696,7 @@ S_handle_named_backref(pTHX_ RExC_state_t *pRExC_state, } 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); } @@ -11708,7 +2920,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) vFAIL("Too many nested open parens"); } - *flagp = 0; /* Initialize. */ + *flagp = 0; /* Initialize. */ /* Having this true makes it feasible to have a lot fewer tests for the * parse pointer being in scope. For example, we can write @@ -12034,7 +3246,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) 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, + ARG(REGNODE_p(ret)) = reg_add_data( pRExC_state, STR_WITH_LEN("S")); RExC_rxi->data->data[ARG(REGNODE_p(ret))]=(void*)sv; FLAGS(REGNODE_p(ret)) = 1; @@ -12066,10 +3278,10 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) if (RExC_parse > RExC_end) { paren = '\0'; } - ret = 0; /* For look-ahead/behind. */ + ret = 0; /* For look-ahead/behind. */ switch (paren) { - case 'P': /* (?P...) variants for those used to PCRE/Python */ + case 'P': /* (?P...) variants for those used to PCRE/Python */ paren = *RExC_parse; if ( paren == '<') { /* (?P<...>) named capture */ RExC_parse_inc_by(1); @@ -12412,13 +3624,13 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) 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; } @@ -12511,7 +3723,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) } 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); } @@ -12783,12 +3995,12 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) else if (paren == ':') { *flagp |= flags&SIMPLE; } - if (is_open) { /* Starts with OPEN. */ + if (is_open) { /* Starts with OPEN. */ if (! REGTAIL(pRExC_state, ret, br)) { /* OPEN -> first. */ REQUIRE_BRANCHJ(flagp, 0); } } - else if (paren != '?') /* Not Conditional */ + else if (paren != '?') /* Not Conditional */ ret = br; *flagp |= flags & (HASWIDTH | POSTPONED); lastbr = br; @@ -13005,7 +4217,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) vFAIL("Unmatched )"); } else - FAIL("Junk on end of regexp"); /* "Can't happen". */ + FAIL("Junk on end of regexp"); /* "Can't happen". */ NOT_REACHED; /* NOTREACHED */ } @@ -13052,7 +4264,7 @@ S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth) } } - *flagp = 0; /* Initialize. */ + *flagp = 0; /* Initialize. */ skip_to_be_ignored_text(pRExC_state, &RExC_parse, FALSE /* Don't force to /x */ ); @@ -13082,7 +4294,7 @@ S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth) chain = latest; c++; } - if (chain == 0) { /* Loop ran zero times. */ + if (chain == 0) { /* Loop ran zero times. */ chain = reg_node(pRExC_state, NOTHING); if (ret == 0) ret = chain; @@ -14004,14 +5216,6 @@ S_backref_value(char *p, char *e) return I32_MAX; } -#ifdef DEBUGGING -#define REGNODE_GUTS(state,op,extra_size) \ - regnode_guts_debug(state,op,extra_size) -#else -#define REGNODE_GUTS(state,op,extra_size) \ - regnode_guts(state,extra_size) -#endif - /* - regatom - the lowest level @@ -14093,7 +5297,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) DECLARE_AND_GET_RE_DEBUG_FLAGS; - *flagp = 0; /* Initialize. */ + *flagp = 0; /* Initialize. */ DEBUG_PARSE("atom"); @@ -14249,7 +5453,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) else { ret = reg_node(pRExC_state, SEOL); } - RExC_seen_zerolen++; /* Do not optimize RE away */ + RExC_seen_zerolen++; /* Do not optimize RE away */ goto finish_meta_pat; case 'z': if (RExC_pm_flags & PMf_WILDCARD) { @@ -14259,7 +5463,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) else { ret = reg_node(pRExC_state, EOS); } - RExC_seen_zerolen++; /* Do not optimize RE away */ + RExC_seen_zerolen++; /* Do not optimize RE away */ goto finish_meta_pat; case 'C': vFAIL("\\C no longer supported"); @@ -16046,8 +7250,8 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) } -STATIC void -S_populate_anyof_bitmap_from_invlist(pTHX_ regnode *node, SV** invlist_ptr) +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 @@ -16962,7 +8166,7 @@ S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist, /* Handle the (?[...]) construct to do set operations */ U8 curchar; /* Current character being parsed */ - UV start, end; /* End points of code point ranges */ + UV start, end; /* End points of code point ranges */ SV* final = NULL; /* The end result inversion list */ SV* result_string; /* 'final' stringified */ AV* stack; /* stack of operators and operands not yet @@ -17698,8 +8902,8 @@ S_dump_regex_sets_structures(pTHX_ RExC_state_t *pRExC_state, #undef IS_OPERATOR #undef IS_OPERAND -STATIC void -S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invlist) +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. * @@ -18073,7 +9277,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, assert(RExC_parse <= RExC_end); - if (UCHARAT(RExC_parse) == '^') { /* Complement the class */ + if (UCHARAT(RExC_parse) == '^') { /* Complement the class */ RExC_parse_inc_by(1); invert = TRUE; allow_mutiple_chars = FALSE; @@ -18236,16 +9440,16 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, 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; @@ -18544,15 +9748,15 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, 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 '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' */ + RExC_parse--; /* function expects to be pointed at the 'o' */ if (! grok_bslash_o(&RExC_parse, RExC_end, &value, @@ -18574,7 +9778,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, } break; case 'x': - RExC_parse--; /* function expects to be pointed at the 'x' */ + RExC_parse--; /* function expects to be pointed at the 'x' */ if (! grok_bslash_x(&RExC_parse, RExC_end, &value, @@ -18886,8 +10090,8 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, cp_list = add_cp_to_invlist(cp_list, '-'); element_count++; } else - range = 1; /* yeah, it's a range! */ - continue; /* but do it the next time */ + range = 1; /* yeah, it's a range! */ + continue; /* but do it the next time */ } } } @@ -19277,7 +10481,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * ones already on the list */ if (cp_foldable_list) { if (FOLD) { - UV start, end; /* End points of code point ranges */ + UV start, end; /* End points of code point ranges */ SV* fold_intersection = NULL; SV** use_list; @@ -20711,8 +11915,8 @@ S_optimize_regclass(pTHX_ #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION -STATIC void -S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state, +void +Perl_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state, regnode* const node, SV* const cp_list, SV* const runtime_defns, @@ -20724,7 +11928,7 @@ S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state, * 1) ANYOF_MATCHES_NONE_OUTSIDE_BITMAP_VALUE * 2) ANYOF_MATCHES_ALL_OUTSIDE_BITMAP_VALUE * - * Otherwise, it sets the argument to the count returned by add_data(), + * 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. @@ -20863,7 +12067,7 @@ S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state, } rv = newRV_noinc(MUTABLE_SV(av)); - n = add_data(pRExC_state, STR_WITH_LEN("s")); + n = reg_add_data(pRExC_state, STR_WITH_LEN("s")); RExC_rxi->data->data[n] = (void*)rv; ARG_SET(node, n); } @@ -21437,7 +12641,7 @@ S_reginsert(pTHX_ RExC_state_t *pRExC_state, const U8 op, StructCopy(--src, --dst, regnode); } - place = REGNODE_p(operand); /* Op node, where operand used to be. */ + place = REGNODE_p(operand); /* Op node, where operand used to be. */ src = place + 1; /* NOT REGNODE_AFTER! */ FLAGS(place) = 0; FILL_NODE(operand, op); @@ -21548,7 +12752,7 @@ S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode_offset p, regnode * const temp = regnext(REGNODE_p(scan)); #ifdef EXPERIMENTAL_INPLACESCAN if (REGNODE_TYPE(OP(REGNODE_p(scan))) == EXACT) { - bool unfolded_multi_char; /* Unexamined in this routine */ + 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 */ @@ -21606,8 +12810,8 @@ S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode_offset p, } #endif -STATIC SV* -S_get_ANYOFM_contents(pTHX_ const regnode * n) { +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' */ @@ -21639,8 +12843,8 @@ S_get_ANYOFM_contents(pTHX_ const regnode * n) { return cp_list; } -STATIC SV * -S_get_ANYOFHbbm_contents(pTHX_ const regnode * n) { +SV * +Perl_get_ANYOFHbbm_contents(pTHX_ const regnode * n) { PERL_ARGS_ASSERT_GET_ANYOFHBBM_CONTENTS; SV * cp_list = NULL; @@ -21655,716 +12859,11 @@ S_get_ANYOFHbbm_contents(pTHX_ const regnode * n) { 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 & (1U<<bit)) { - if ((1U<<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 - U8 k; - const U8 op = OP(o); - RXi_GET_DECL(prog, progi); - DECLARE_AND_GET_RE_DEBUG_FLAGS; - - PERL_ARGS_ASSERT_REGPROP; - - SvPVCLEAR(sv); - - if (op > 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, (int)REGNODE_MAX); - } - else { - Perl_croak(aTHX_ "panic: corrupted regexp opcode %d > %d", - (int)op, (int)REGNODE_MAX); - } - } - sv_catpv(sv, REGNODE_NAME(op)); /* Take off const! */ - - k = REGNODE_TYPE(op); - - 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 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", REGNODE_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 == CURLYM || op == CURLYN || op == 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 == ACCEPT) - { - AV *name_list= NULL; - U32 parno= (op == ACCEPT) ? (U32)ARG2L(o) : - (op == OPEN || op == CLOSE) ? (U32)PARNO(o) : - (U32)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 < REFN)) { - SV **name= av_fetch_simple(name_list, parno, 0 ); - if (name) - Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name)); - } - else - if (parno > 0) { - /* parno must always be larger than 0 for this block - * as it represents a slot into the data array, which - * has the 0 slot reserved for a placeholder so any valid - * index into it is always true, eg non-zero - * see the '%' "what" type and the implementation of - * S_add_data() - */ - SV *sv_dat= MUTABLE_SV(progi->data->data[ parno ]); - I32 *nums=(I32*)SvPVX(sv_dat); - SV **name= av_fetch_simple(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_simple(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 == ANYOFH || k == ANYOFR) { - U8 flags; - char * bitmap; - U8 do_sep = 0; /* 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 (k != ANYOF) { - flags = 0; - bitmap = NULL; - } - else { - flags = ANYOF_FLAGS(o); - bitmap = ANYOF_BITMAP(o); - } - - if (op == ANYOFL || op == ANYOFPOSIXL) { - if ((flags & ANYOFL_UTF8_LOCALE_REQD)) { - 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 (k == ANYOFR) { - - /* For a single range, split into the parts inside vs outside the - * bitmap. */ - UV start = ANYOFRbase(o); - UV end = ANYOFRbase(o) + ANYOFRdelta(o); - - if (start < NUM_ANYOF_CODE_POINTS) { - if (end < NUM_ANYOF_CODE_POINTS) { - bitmap_range_not_in_bitmap - = _add_range_to_invlist(bitmap_range_not_in_bitmap, - start, end); - } - else { - bitmap_range_not_in_bitmap - = _add_range_to_invlist(bitmap_range_not_in_bitmap, - start, NUM_ANYOF_CODE_POINTS); - start = NUM_ANYOF_CODE_POINTS; - } - } - - if (start >= NUM_ANYOF_CODE_POINTS) { - nonbitmap_invlist = _add_range_to_invlist(nonbitmap_invlist, - ANYOFRbase(o), - ANYOFRbase(o) + ANYOFRdelta(o)); - } - } - else if (ANYOF_MATCHES_ALL_OUTSIDE_BITMAP(o)) { - nonbitmap_invlist = _add_range_to_invlist(nonbitmap_invlist, - NUM_ANYOF_CODE_POINTS, - UV_MAX); - } - else if (ANYOF_HAS_AUX(o)) { - (void) GET_REGCLASS_AUX_DATA(prog, o, FALSE, - &unresolved, - &only_utf8_locale_invlist, - &nonbitmap_invlist); - - /* The aux 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); - } - - /* Ready to start outputting. First, the initial left bracket */ - Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]); - - if ( bitmap - || bitmap_range_not_in_bitmap - || only_utf8_locale_invlist - || unresolved) - { - /* 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 || k == ANYOFR)); - 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; - } - else if ( do_sep == 2 - && ! nonbitmap_invlist - && ANYOF_MATCHES_NONE_OUTSIDE_BITMAP(o)) - { - /* Here, the display shows the class as inverted, and - * everything above the lower display should also match, but - * there is no indication of that. Add this range so the code - * below will add it to the display */ - _invlist_union_complement_2nd(nonbitmap_invlist, - PL_InBitmap, - &nonbitmap_invlist); - } - } - - /* 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 == 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 (REGNODE_TYPE(op) != ANYOF) { - U8 lowest = (op != ANYOFHr) - ? FLAGS(o) - : LOWEST_ANYOF_HRx_BYTE(FLAGS(o)); - U8 highest = (op == ANYOFHr) - ? HIGHEST_ANYOF_HRx_BYTE(FLAGS(o)) - : (op == ANYOFH || op == ANYOFR) - ? 0xFF - : lowest; -#ifndef EBCDIC - if (op != 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 == 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 == ANYOFHbbm) { - SV * cp_list = get_ANYOFHbbm_contents(o); - Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]); - - sv_catsv(sv, invlist_contents(cp_list, - FALSE /* output suitable for catsv */ - )); - 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 == UNLESSM || op == 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 == SBOL) - Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^"); - - /* add on the verb argument if there is one */ - if ( ( k == VERB || op == ACCEPT || op == 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_re_intuit_string(pTHX_ REGEXP * const r) -{ /* Assume that RE_INTUIT is set */ +{ /* Assume that RE_INTUIT is set */ /* Returns an SV containing a string that must appear in the target for it * to match, or NULL if nothing is known that must match. * @@ -22686,7 +13185,7 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx) } break; case '%': - /* NO-OP a '%' data contains a null pointer, so that add_data + /* 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); @@ -22703,9 +13202,9 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx) 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) +#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) /* =for apidoc re_dup_guts @@ -22921,7 +13420,7 @@ Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param) break; case '%': /* this is a placeholder type, it exists purely so that - * add_data always returns a non-zero value, this type of + * 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]; @@ -23014,778 +13513,6 @@ Perl_save_re_context(pTHX) } #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 U8 -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 0 if nothing was actually output. (It may be that - * the bitmap, etc is empty.) - * 1 if the output wasn't inverted (didn't begin with a '^') - * 2 if the output was inverted (did begin with a '^') - * - * 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_HAS_EXTRA_RUNTIME_MATCHES) { - _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 & ANYOFD_NON_UTF8_MATCHES_ALL_NON_ASCII__shared) { - 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 '^' */ - bool trial_invert; - if (invert) { - trial_invert = FALSE; - as_is_bias = bias; - inverted_bias = 0; - } - else { - trial_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, trial_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); - invert = ! invert; - } - 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); - - U8 did_output_something = (bool) (SvCUR(sv) > orig_sv_cur); - if (did_output_something) { - /* Distinguish between non and inverted cases */ - did_output_something += invert; - } - - return did_output_something; -} - -#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) -{ - 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 (node && (!last || node < last)) { - const U8 op = OP(node); - - if (op == CLOSE || op == SRCLOSE || op == WHILEM) - indent--; - next = regnext((regnode *)node); - const regnode *after = regnode_after((regnode *)node,0); - - /* Where, what. */ - if (op == 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 != OPTIMIZED) { - if (next == NULL) /* Next ptr. */ - Perl_re_printf( aTHX_ " (0)"); - else if (REGNODE_TYPE(op) == BRANCH - && REGNODE_TYPE(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 (REGNODE_TYPE(op) == BRANCHJ) { - assert(next); - const regnode *nnode = (OP(next) == LONGJMP - ? regnext((regnode *)next) - : next); - if (last && nnode > last) - nnode = last; - DUMPUNTIL(after, nnode); - } - else if (REGNODE_TYPE(op) == BRANCH) { - assert(next); - DUMPUNTIL(after, next); - } - else if ( REGNODE_TYPE(op) == TRIE ) { - const regnode *this_trie = 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_simple(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 && REGNODE_TYPE(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(after, after + 1); /* +1 is NOT a REGNODE_AFTER */ - } - else if (REGNODE_TYPE(op) == CURLY && op != CURLYX) { - assert(next); - DUMPUNTIL(after, next); - } - else if ( op == PLUS || op == STAR) { - DUMPUNTIL(after, after + 1); /* +1 NOT a REGNODE_AFTER */ - } - else if (REGNODE_TYPE(op) == EXACT || op == ANYOFHs) { - /* Literal string, where present. */ - node = (const regnode *)REGNODE_AFTER_varies(node); - } - else { - node = REGNODE_AFTER_opcode(node,op); - } - if (op == CURLYX || op == OPEN || op == SROPEN) - indent++; - if (REGNODE_TYPE(op) == END) - break; - } - 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" @@ -23939,7 +13666,7 @@ warning when none was present before might cause breakage, for little gain. So khw left this code in, but not enabled. Tests were never added. embed.fnc entry: -Ei |const char *|get_extended_utf8_msg|const UV cp +Ei |const char *|get_extended_utf8_msg|const UV cp PERL_STATIC_INLINE const char * S_get_extended_utf8_msg(pTHX_ const UV cp) |