X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/099ec7dcf9e085a650e6d9010c12ad9649209bf4..34fdef848b1687b91892ba55e9e0c3430e0770f6:/regcomp.c diff --git a/regcomp.c b/regcomp.c index 5800d36..96bf775 100644 --- a/regcomp.c +++ b/regcomp.c @@ -91,7 +91,8 @@ EXTERN_C const struct regexp_engine my_reg_engine; #include "inline_invlist.c" #include "unicode_constants.h" -#define HAS_NONLATIN1_FOLD_CLOSURE(i) _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i) +#define HAS_NONLATIN1_FOLD_CLOSURE(i) \ + _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i) #define IS_NON_FINAL_FOLD(c) _IS_NON_FINAL_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c) #define IS_IN_SOME_FOLD_L1(c) _IS_IN_SOME_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c) @@ -106,13 +107,15 @@ struct RExC_state_t { char *precomp; /* 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 */ + 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. */ SSize_t whilem_seen; /* number of WHILEM in this expr */ regnode *emit_start; /* Start of emitted-code area */ - regnode *emit_bound; /* First regnode outside of the allocated space */ + regnode *emit_bound; /* First regnode outside of the + allocated space */ regnode *emit; /* Code-emit pointer; if = &emit_dummy, implies compiling, so don't emit */ regnode_ssc emit_dummy; /* placeholder for emit to point to; @@ -123,9 +126,11 @@ struct RExC_state_t { I32 sawback; /* Did we see \1, ...? */ U32 seen; SSize_t size; /* Code size. */ - I32 npar; /* Capture buffer count, (OPEN). */ - I32 cpar; /* Capture buffer count, (CLOSE). */ - I32 nestroot; /* root parens we are in - used by accept */ + I32 npar; /* Capture buffer count, (OPEN) plus + one. ("par" 0 is the whole + pattern)*/ + I32 nestroot; /* root parens we are in - used by + accept */ I32 extralen; I32 seen_zerolen; regnode **open_parens; /* pointers to open parens */ @@ -139,9 +144,12 @@ struct RExC_state_t { rules, even if the pattern is not in utf8 */ HV *paren_names; /* Paren names */ - + regnode **recurse; /* Recurse regops */ I32 recurse_count; /* Number of recurse regops */ + U8 *study_chunk_recursed; /* bitmap of which parens we have moved + through */ + U32 study_chunk_recursed_bytes; /* bytes in bitmap */ I32 in_lookbehind; I32 contains_locale; I32 contains_i; @@ -151,7 +159,8 @@ struct RExC_state_t { within pattern */ int num_code_blocks; /* size of code_blocks[] */ int code_index; /* next code_blocks[] slot */ -#if ADD_TO_REGEXEC + SSize_t maxlen; /* mininum possible number of chars in string to match */ +#ifdef ADD_TO_REGEXEC char *starttry; /* -Dr: where regtry was called. */ #define RExC_starttry (pRExC_state->starttry) #endif @@ -177,7 +186,8 @@ struct RExC_state_t { #define RExC_parse (pRExC_state->parse) #define RExC_whilem_seen (pRExC_state->whilem_seen) #ifdef RE_TRACK_PATTERN_OFFSETS -#define RExC_offsets (pRExC_state->rxi->u.offsets) /* I am not like the others */ +#define RExC_offsets (pRExC_state->rxi->u.offsets) /* I am not like the + others */ #endif #define RExC_emit (pRExC_state->emit) #define RExC_emit_dummy (pRExC_state->emit_dummy) @@ -187,6 +197,7 @@ struct RExC_state_t { #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_nestroot (pRExC_state->nestroot) #define RExC_extralen (pRExC_state->extralen) @@ -200,6 +211,9 @@ struct RExC_state_t { #define RExC_paren_names (pRExC_state->paren_names) #define RExC_recurse (pRExC_state->recurse) #define RExC_recurse_count (pRExC_state->recurse_count) +#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_lookbehind (pRExC_state->in_lookbehind) #define RExC_contains_locale (pRExC_state->contains_locale) #define RExC_contains_i (pRExC_state->contains_i) @@ -266,73 +280,73 @@ struct RExC_state_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 + 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: - + - offset or 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 + 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 SSize_t_MAX it indicates that the string can occur infinitely far to the right. - + - 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 + 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 + 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 + 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 + 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. + 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). + 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 + 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. + and the delta to the maximum offset at the current point in the pattern. */ @@ -411,22 +425,32 @@ static const scan_data_t zero_scan_data = #define SCF_WHILEM_VISITED_POS 0x2000 #define SCF_TRIE_RESTUDY 0x4000 /* Do restudy? */ -#define SCF_SEEN_ACCEPT 0x8000 +#define SCF_SEEN_ACCEPT 0x8000 #define SCF_TRIE_DOING_RESTUDY 0x10000 #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 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 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 @@ -449,7 +473,8 @@ static const scan_data_t zero_scan_data = #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"/" +#define REPORT_LOCATION " in regex; marked by " MARKER1 \ + " in m/%"UTF8f MARKER2 "%"UTF8f"/" #define REPORT_LOCATION_ARGS(offset) \ UTF8fARG(UTF, offset, RExC_precomp), \ @@ -644,7 +669,7 @@ static const scan_data_t zero_scan_data = if (!SIZE_ONLY) *(s) = (c); else (void)(s); \ } STMT_END -/* Macros for recording node offsets. 20001227 mjd@plover.com +/* Macros for recording node offsets. 20001227 mjd@plover.com * Nodes are numbered 1, 2, 3, 4. Node #n's position is recorded in * element 2*n-1 of the array. Element #2n holds the byte length node #n. * Element 0 holds the number n. @@ -657,8 +682,8 @@ static const scan_data_t zero_scan_data = #define Set_Node_Length_To_R(node,len) #define Set_Node_Length(node,len) #define Set_Node_Cur_Length(node,start) -#define Node_Offset(n) -#define Node_Length(n) +#define Node_Offset(n) +#define Node_Length(n) #define Set_Node_Offset_Length(node,offset,len) #define ProgLen(ri) ri->u.proglen #define SetProgLen(ri,x) ri->u.proglen = x @@ -670,7 +695,8 @@ static const scan_data_t zero_scan_data = MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n", \ __LINE__, (int)(node), (int)(byte))); \ if((node) < 0) { \ - Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \ + Perl_croak(aTHX_ "value of node is %d in Offset macro", \ + (int)(node)); \ } else { \ RExC_offsets[2*(node)-1] = (byte); \ } \ @@ -686,7 +712,8 @@ static const scan_data_t zero_scan_data = MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n", \ __LINE__, (int)(node), (int)(len))); \ if((node) < 0) { \ - Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \ + Perl_croak(aTHX_ "value of node is %d in Length macro", \ + (int)(node)); \ } else { \ RExC_offsets[2*(node)] = (len); \ } \ @@ -712,6 +739,49 @@ static const scan_data_t zero_scan_data = #define EXPERIMENTAL_INPLACESCAN #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/ +#define DEBUG_RExC_seen() \ + DEBUG_OPTIMISE_MORE_r({ \ + PerlIO_printf(Perl_debug_log,"RExC_seen: "); \ + \ + if (RExC_seen & REG_ZERO_LEN_SEEN) \ + PerlIO_printf(Perl_debug_log,"REG_ZERO_LEN_SEEN "); \ + \ + if (RExC_seen & REG_LOOKBEHIND_SEEN) \ + PerlIO_printf(Perl_debug_log,"REG_LOOKBEHIND_SEEN "); \ + \ + if (RExC_seen & REG_GPOS_SEEN) \ + PerlIO_printf(Perl_debug_log,"REG_GPOS_SEEN "); \ + \ + if (RExC_seen & REG_CANY_SEEN) \ + PerlIO_printf(Perl_debug_log,"REG_CANY_SEEN "); \ + \ + if (RExC_seen & REG_RECURSE_SEEN) \ + PerlIO_printf(Perl_debug_log,"REG_RECURSE_SEEN "); \ + \ + if (RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN) \ + PerlIO_printf(Perl_debug_log,"REG_TOP_LEVEL_BRANCHES_SEEN "); \ + \ + if (RExC_seen & REG_VERBARG_SEEN) \ + PerlIO_printf(Perl_debug_log,"REG_VERBARG_SEEN "); \ + \ + if (RExC_seen & REG_CUTGROUP_SEEN) \ + PerlIO_printf(Perl_debug_log,"REG_CUTGROUP_SEEN "); \ + \ + if (RExC_seen & REG_RUN_ON_COMMENT_SEEN) \ + PerlIO_printf(Perl_debug_log,"REG_RUN_ON_COMMENT_SEEN "); \ + \ + if (RExC_seen & REG_UNFOLDED_MULTI_SEEN) \ + PerlIO_printf(Perl_debug_log,"REG_UNFOLDED_MULTI_SEEN "); \ + \ + if (RExC_seen & REG_GOSTART_SEEN) \ + PerlIO_printf(Perl_debug_log,"REG_GOSTART_SEEN "); \ + \ + if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) \ + PerlIO_printf(Perl_debug_log,"REG_UNBOUNDED_QUANTIFIER_SEEN "); \ + \ + PerlIO_printf(Perl_debug_log,"\n"); \ + }); + #define DEBUG_STUDYDATA(str,data,depth) \ DEBUG_OPTIMISE_MORE_r(if(data){ \ PerlIO_printf(Perl_debug_log, \ @@ -815,7 +885,7 @@ S_ssc_anything(pTHX_ regnode_ssc *ssc) PERL_ARGS_ASSERT_SSC_ANYTHING; - assert(OP(ssc) == ANYOF_SYNTHETIC); + assert(is_ANYOF_SYNTHETIC(ssc)); ssc->invlist = sv_2mortal(_new_invlist(2)); /* mortalize so won't leak */ _append_range_to_invlist(ssc->invlist, 0, UV_MAX); @@ -835,7 +905,7 @@ S_ssc_is_anything(pTHX_ const regnode_ssc *ssc) PERL_ARGS_ASSERT_SSC_IS_ANYTHING; - assert(OP(ssc) == ANYOF_SYNTHETIC); + assert(is_ANYOF_SYNTHETIC(ssc)); if (! (ANYOF_FLAGS(ssc) & ANYOF_EMPTY_STRING)) { return FALSE; @@ -875,7 +945,7 @@ S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc) PERL_ARGS_ASSERT_SSC_INIT; Zero(ssc, 1, regnode_ssc); - OP(ssc) = ANYOF_SYNTHETIC; + set_ANYOF_SYNTHETIC(ssc); ARG_SET(ssc, ANYOF_NONBITMAP_EMPTY); ssc_anything(ssc); @@ -889,9 +959,6 @@ S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc) if (RExC_contains_locale) { ANYOF_POSIXL_SETALL(ssc); ANYOF_FLAGS(ssc) |= ANYOF_LOCALE|ANYOF_POSIXL; - if (RExC_contains_i) { - ANYOF_FLAGS(ssc) |= ANYOF_LOC_FOLD; - } } else { ANYOF_POSIXL_ZERO(ssc); @@ -911,7 +978,7 @@ S_ssc_is_cp_posixl_init(pTHX_ const RExC_state_t *pRExC_state, PERL_ARGS_ASSERT_SSC_IS_CP_POSIXL_INIT; - assert(OP(ssc) == ANYOF_SYNTHETIC); + assert(is_ANYOF_SYNTHETIC(ssc)); invlist_iterinit(ssc->invlist); ret = invlist_iternext(ssc->invlist, &start, &end) @@ -924,16 +991,12 @@ S_ssc_is_cp_posixl_init(pTHX_ const RExC_state_t *pRExC_state, return FALSE; } - if (RExC_contains_locale) { - if (! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE) - || ! (ANYOF_FLAGS(ssc) & ANYOF_POSIXL) - || ! ANYOF_POSIXL_TEST_ALL_SET(ssc)) - { - return FALSE; - } - if (RExC_contains_i && ! (ANYOF_FLAGS(ssc) & ANYOF_LOC_FOLD)) { - return FALSE; - } + if (RExC_contains_locale + && ! ((ANYOF_FLAGS(ssc) & ANYOF_LOCALE) + || ! (ANYOF_FLAGS(ssc) & ANYOF_POSIXL) + || ! ANYOF_POSIXL_TEST_ALL_SET(ssc))) + { + return FALSE; } return TRUE; @@ -941,16 +1004,18 @@ S_ssc_is_cp_posixl_init(pTHX_ const RExC_state_t *pRExC_state, STATIC SV* S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state, - const regnode_charclass_posixl* const node) + const regnode_charclass_posixl_fold* const node) { /* Returns a mortal inversion list defining which code points are matched * by 'node', which is of type ANYOF. Handles complementing the result if * appropriate. If some code points aren't knowable at this time, the - * returned list must, and will, contain every possible code point. */ + * returned list must, and will, contain every code point that is a + * possibility. */ SV* invlist = sv_2mortal(_new_invlist(0)); unsigned int i; const U32 n = ARG(node); + bool new_node_has_latin1 = FALSE; PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC; @@ -997,12 +1062,13 @@ S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state, for (i = 0; i < 256; i++) { if (ANYOF_BITMAP_TEST(node, i)) { invlist = add_cp_to_invlist(invlist, i); + new_node_has_latin1 = TRUE; } } /* If this can match all upper Latin1 code points, have to add them * as well */ - if (ANYOF_FLAGS(node) & ANYOF_NON_UTF8_LATIN1_ALL) { + if (OP(node) == ANYOF_NON_UTF8_NON_ASCII_ALL) { _invlist_union(invlist, PL_UpperLatin1, &invlist); } @@ -1014,6 +1080,21 @@ S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state, if (ANYOF_FLAGS(node) & ANYOF_INVERT) { _invlist_invert(invlist); } + else if (new_node_has_latin1 && ANYOF_FLAGS(node) & ANYOF_LOC_FOLD) { + + /* 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); + } + + /* Similarly add the UTF-8 locale possible matches */ + if (ANYOF_FLAGS(node) & ANYOF_LOC_FOLD && ANYOF_UTF8_LOCALE_INVLIST(node)) + { + _invlist_union_maybe_complement_2nd(invlist, + ANYOF_UTF8_LOCALE_INVLIST(node), + ANYOF_FLAGS(node) & ANYOF_INVERT, + &invlist); + } return invlist; } @@ -1032,12 +1113,12 @@ S_ssc_flags_and(regnode_ssc *ssc, const U8 and_with) * The flags 'and_with' should not come from another SSC (otherwise the * EMPTY_STRING flag won't work) */ - const U8 ssc_only_flags = ANYOF_FLAGS(ssc) & ~ANYOF_LOCALE_FLAGS; + const U8 ssc_only_flags = ANYOF_FLAGS(ssc) & ~ANYOF_COMMON_FLAGS; PERL_ARGS_ASSERT_SSC_FLAGS_AND; /* Use just the SSC-related flags from 'and_with' */ - ANYOF_FLAGS(ssc) &= (and_with & ANYOF_LOCALE_FLAGS); + ANYOF_FLAGS(ssc) &= (and_with & ANYOF_COMMON_FLAGS); ANYOF_FLAGS(ssc) |= ssc_only_flags; } @@ -1057,18 +1138,37 @@ S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc, PERL_ARGS_ASSERT_SSC_AND; - assert(OP(ssc) == ANYOF_SYNTHETIC); + 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 (OP(and_with) == ANYOF_SYNTHETIC) { + if (is_ANYOF_SYNTHETIC(and_with)) { anded_cp_list = and_with->invlist; anded_flags = ANYOF_FLAGS(and_with); + + /* 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(and_with)) { + anded_flags |= ANYOF_WARN_SUPER; + } } else { anded_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, - (regnode_charclass_posixl*) and_with); - anded_flags = ANYOF_FLAGS(and_with) & ANYOF_LOCALE_FLAGS; + (regnode_charclass_posixl_fold*) and_with); + anded_flags = ANYOF_FLAGS(and_with) & ANYOF_COMMON_FLAGS; } ANYOF_FLAGS(ssc) &= anded_flags; @@ -1105,7 +1205,7 @@ S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc, * */ if ((ANYOF_FLAGS(and_with) & ANYOF_INVERT) - && OP(and_with) != ANYOF_SYNTHETIC) + && ! is_ANYOF_SYNTHETIC(and_with)) { unsigned int i; @@ -1144,7 +1244,7 @@ S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc, * standard, in particular almost everything by Microsoft. * The loop below just changes e.g., \w into \W and vice versa */ - regnode_charclass_posixl temp; + regnode_charclass_posixl_fold temp; int add = 1; /* To calculate the index of the complement */ ANYOF_POSIXL_ZERO(&temp); @@ -1163,13 +1263,13 @@ S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *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 (OP(and_with) != ANYOF_SYNTHETIC + else if (! is_ANYOF_SYNTHETIC(and_with) || ! ssc_is_cp_posixl_init(pRExC_state, 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 (OP(and_with) == ANYOF_SYNTHETIC) { + if (is_ANYOF_SYNTHETIC(and_with)) { StructCopy(and_with, ssc, regnode_ssc); } else { @@ -1206,18 +1306,18 @@ S_ssc_or(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc, PERL_ARGS_ASSERT_SSC_OR; - assert(OP(ssc) == ANYOF_SYNTHETIC); + 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 (OP(or_with) == ANYOF_SYNTHETIC) { + if (is_ANYOF_SYNTHETIC(or_with)) { ored_cp_list = or_with->invlist; ored_flags = ANYOF_FLAGS(or_with); } else { ored_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, - (regnode_charclass_posixl*) or_with); - ored_flags = ANYOF_FLAGS(or_with) & ANYOF_LOCALE_FLAGS; + (regnode_charclass_posixl_fold*) or_with); + ored_flags = ANYOF_FLAGS(or_with) & ANYOF_COMMON_FLAGS; } ANYOF_FLAGS(ssc) |= ored_flags; @@ -1241,7 +1341,7 @@ S_ssc_or(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc, * */ if ((ANYOF_FLAGS(or_with) & ANYOF_INVERT) - && OP(or_with) != ANYOF_SYNTHETIC) + && ! is_ANYOF_SYNTHETIC(or_with)) { /* We ignore P2, leaving P1 going forward */ } @@ -1274,7 +1374,7 @@ S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, const bool invert2nd) { PERL_ARGS_ASSERT_SSC_UNION; - assert(OP(ssc) == ANYOF_SYNTHETIC); + assert(is_ANYOF_SYNTHETIC(ssc)); _invlist_union_maybe_complement_2nd(ssc->invlist, invlist, @@ -1289,7 +1389,7 @@ S_ssc_intersection(pTHX_ regnode_ssc *ssc, { PERL_ARGS_ASSERT_SSC_INTERSECTION; - assert(OP(ssc) == ANYOF_SYNTHETIC); + assert(is_ANYOF_SYNTHETIC(ssc)); _invlist_intersection_maybe_complement_2nd(ssc->invlist, invlist, @@ -1302,7 +1402,7 @@ S_ssc_add_range(pTHX_ regnode_ssc *ssc, const UV start, const UV end) { PERL_ARGS_ASSERT_SSC_ADD_RANGE; - assert(OP(ssc) == ANYOF_SYNTHETIC); + assert(is_ANYOF_SYNTHETIC(ssc)); ssc->invlist = _add_range_to_invlist(ssc->invlist, start, end); } @@ -1316,7 +1416,7 @@ S_ssc_cp_and(pTHX_ regnode_ssc *ssc, const UV cp) PERL_ARGS_ASSERT_SSC_CP_AND; - assert(OP(ssc) == ANYOF_SYNTHETIC); + assert(is_ANYOF_SYNTHETIC(ssc)); cp_list = add_cp_to_invlist(cp_list, cp); ssc_intersection(ssc, cp_list, @@ -1332,7 +1432,7 @@ S_ssc_clear_locale(pTHX_ regnode_ssc *ssc) PERL_ARGS_ASSERT_SSC_CLEAR_LOCALE; - assert(OP(ssc) == ANYOF_SYNTHETIC); + assert(is_ANYOF_SYNTHETIC(ssc)); ANYOF_POSIXL_ZERO(ssc); ANYOF_FLAGS(ssc) &= ~ANYOF_LOCALE_FLAGS; @@ -1349,24 +1449,30 @@ S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc) PERL_ARGS_ASSERT_SSC_FINALIZE; - assert(OP(ssc) == ANYOF_SYNTHETIC); + assert(is_ANYOF_SYNTHETIC(ssc)); /* The code in this file assumes that all but these flags aren't relevant * to the SSC, except ANYOF_EMPTY_STRING, which should be cleared by the * time we reach here */ - assert(! (ANYOF_FLAGS(ssc) & ~ANYOF_LOCALE_FLAGS)); + assert(! (ANYOF_FLAGS(ssc) & ~ANYOF_COMMON_FLAGS)); populate_ANYOF_from_invlist( (regnode *) ssc, &invlist); set_ANYOF_arg(pRExC_state, (regnode *) ssc, invlist, NULL, NULL, FALSE); + /* The code points that could match under /li are already incorporated into + * the inversion list and bit map */ + ANYOF_FLAGS(ssc) &= ~ANYOF_LOC_FOLD; + assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE) || 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 ) +#define TRIE_LIST_USED(idx) ( trie->states[state].trans.list \ + ? (TRIE_LIST_CUR( idx ) - 1) \ + : 0 ) #ifdef DEBUGGING @@ -1409,13 +1515,13 @@ S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap, for( state = 0 ; state < trie->uniquecharcount ; state++ ) { SV ** const tmp = av_fetch( revcharmap, state, 0); if ( tmp ) { - PerlIO_printf( Perl_debug_log, "%*s", + PerlIO_printf( Perl_debug_log, "%*s", colwidth, - pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 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_PV_ESCAPE_FIRSTCHAR + ) ); } } @@ -1429,10 +1535,12 @@ S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap, for( state = 1 ; state < trie->statecount ; state++ ) { const U32 base = trie->states[ state ].trans.base; - PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state); + PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", + (int)depth * 2 + 2,"", (UV)state); if ( trie->states[ state ].wordnum ) { - PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum ); + PerlIO_printf( Perl_debug_log, " W%4X", + trie->states[ state ].wordnum ); } else { PerlIO_printf( Perl_debug_log, "%6s", "" ); } @@ -1444,19 +1552,23 @@ S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap, while( ( base + ofs < trie->uniquecharcount ) || ( base + ofs - trie->uniquecharcount < trie->lasttrans - && trie->trans[ base + ofs - trie->uniquecharcount ].check != state)) + && trie->trans[ base + ofs - trie->uniquecharcount ].check + != state)) ofs++; PerlIO_printf( Perl_debug_log, "+%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 ) + if ( ( base + ofs >= trie->uniquecharcount ) + && ( base + ofs - trie->uniquecharcount + < trie->lasttrans ) + && trie->trans[ base + ofs + - trie->uniquecharcount ].check == state ) { PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, - (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next ); + (UV)trie->trans[ base + ofs + - trie->uniquecharcount ].next ); } else { PerlIO_printf( Perl_debug_log, "%*s",colwidth," ." ); } @@ -1467,17 +1579,18 @@ S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap, } PerlIO_printf( Perl_debug_log, "\n" ); } - PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=", (int)depth*2, ""); + PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=", + (int)depth*2, ""); for (word=1; word <= trie->wordcount; word++) { PerlIO_printf(Perl_debug_log, " %d:(%d,%d)", (int)word, (int)(trie->wordinfo[word].prev), (int)(trie->wordinfo[word].len)); } PerlIO_printf(Perl_debug_log, "\n" ); -} +} /* Dumps a fully constructed but uncompressed trie in list form. - List tries normally only are used for construction when the number of + List tries normally only are used for construction when the number of possible chars (trie->uniquecharcount) is very high. Used for debugging make_trie(). */ @@ -1497,10 +1610,10 @@ S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s", (int)depth * 2 + 2,"", (int)depth * 2 + 2,"", "------:-----+-----------------\n" ); - + for( state=1 ; state < next_alloc ; state ++ ) { U16 charid; - + PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :", (int)depth * 2 + 2,"", (UV)state ); if ( ! trie->states[ state ].wordnum ) { @@ -1511,31 +1624,33 @@ S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, ); } for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) { - SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0); + SV ** const tmp = av_fetch( revcharmap, + TRIE_LIST_ITEM(state,charid).forid, 0); if ( tmp ) { PerlIO_printf( Perl_debug_log, "%*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 + 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)) + if (!(charid % 10)) PerlIO_printf(Perl_debug_log, "\n%*s| ", (int)((depth * 2) + 14), ""); } } PerlIO_printf( Perl_debug_log, "\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. + This is the normal DFA style state transition table, with a few + twists to facilitate compression later. Used for debugging make_trie(). */ STATIC void @@ -1550,24 +1665,24 @@ S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie, GET_RE_DEBUG_FLAGS_DECL; PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE; - + /* print out the table precompression so that we can do a visual check that they are identical. */ - + PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" ); for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) { SV ** const tmp = av_fetch( revcharmap, charid, 0); if ( tmp ) { - PerlIO_printf( Perl_debug_log, "%*s", + PerlIO_printf( Perl_debug_log, "%*s", colwidth, - pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 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_PV_ESCAPE_FIRSTCHAR + ) ); } } @@ -1582,7 +1697,7 @@ S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie, for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) { - PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ", + PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ", (int)depth * 2 + 2,"", (UV)TRIE_NODENUM( state ) ); @@ -1594,9 +1709,11 @@ S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie, PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." ); } if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) { - PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check ); + PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", + (UV)trie->trans[ state ].check ); } else { - PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check, + PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", + (UV)trie->trans[ state ].check, trie->states[ TRIE_NODENUM( state ) ].wordnum ); } } @@ -1802,7 +1919,8 @@ is the recommended Unicode-aware way of saying \ if ( noper_next < tail ) { \ if (!trie->jump) \ - trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, sizeof(U16) ); \ + trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, \ + sizeof(U16) ); \ trie->jump[curword] = (U16)(noper_next - convert); \ if (!jumper) \ jumper = noper_next; \ @@ -1837,7 +1955,9 @@ is the recommended Unicode-aware way of saying #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) +S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, + regnode *first, regnode *last, regnode *tail, + U32 word_count, U32 flags, U32 depth) { dVAR; /* first pass, loop through and scan words */ @@ -1880,7 +2000,6 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs case EXACTFU_SS: case EXACTFU: folder = PL_fold_latin1; break; case EXACTF: folder = PL_fold; break; - case EXACTFL: folder = PL_fold_locale; break; default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] ); } @@ -1904,14 +2023,13 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT); } DEBUG_TRIE_COMPILE_r({ - PerlIO_printf( Perl_debug_log, - "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n", - (int)depth * 2 + 2, "", - REG_NODE_NUM(startbranch),REG_NODE_NUM(first), - REG_NODE_NUM(last), REG_NODE_NUM(tail), - (int)depth); + PerlIO_printf( Perl_debug_log, + "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n", + (int)depth * 2 + 2, "", + 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 */ @@ -1920,7 +2038,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs /* branch sub-chain */ convert = NEXTOPER( first ); } - + /* -- First loop and Setup -- We first traverse the branches and scan each word to determine if it @@ -1929,9 +2047,9 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs 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. + (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 @@ -1952,7 +2070,8 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs U32 wordlen = 0; /* required init */ STRLEN minbytes = 0; STRLEN maxbytes = 0; - bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the bitmap?*/ + bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the + bitmap?*/ if (OP(noper) == NOTHING) { regnode *noper_next= regnext(noper); @@ -2005,7 +2124,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs foldlen -= UTF8SKIP(uc); } else { - foldlen = is_MULTI_CHAR_FOLD_utf8_safe(uc, e); + foldlen = is_MULTI_CHAR_FOLD_utf8(uc); minbytes++; } } @@ -2022,7 +2141,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs foldlen--; } else { - foldlen = is_MULTI_CHAR_FOLD_latin1_safe(uc, e); + foldlen = is_MULTI_CHAR_FOLD_latin1(uc); minbytes++; } } @@ -2082,7 +2201,8 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs } } /* end first pass */ DEBUG_TRIE_COMPILE_r( - PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n", + PerlIO_printf( Perl_debug_log, + "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n", (int)depth * 2 + 2,"", ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count, (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount, @@ -2114,7 +2234,9 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs 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) ) { + if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) + > SvIV(re_trie_maxbuff) ) + { /* Second Pass -- Array Of Lists Representation @@ -2129,7 +2251,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs STRLEN transcount = 1; - DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, + DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, "%*sCompiling trie using list compiler\n", (int)depth * 2 + 2, "")); @@ -2165,14 +2287,18 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs if ( uvc < 256 ) { charid = trie->charmap[ uvc ]; } else { - SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0); + 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 */ + /* charid is now 0 if we dont know the char read, or + * nonzero if we do */ if ( charid ) { U16 check; @@ -2182,8 +2308,13 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs 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 ) { + 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; } @@ -2205,7 +2336,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs } /* end second pass */ /* next alloc is the NEXT state to be allocated */ - trie->statecount = next_alloc; + trie->statecount = next_alloc; trie->states = (reg_trie_state *) PerlMemShared_realloc( trie->states, next_alloc @@ -2253,7 +2384,9 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs PerlMemShared_realloc( trie->trans, transcount * sizeof(reg_trie_trans) ); - Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans ); + Zero( trie->trans + (transcount / 2), + transcount / 2, + reg_trie_trans ); } base = trie->uniquecharcount + tp - minid; if ( maxid == minid ) { @@ -2261,22 +2394,27 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs 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 ].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 ].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; + 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 ); @@ -2328,7 +2466,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs we have to use TRIE_NODENUM() to convert. */ - DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, + DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, "%*sCompiling trie using table compiler\n", (int)depth * 2 + 2, "")); @@ -2372,7 +2510,10 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs if ( uvc < 256 ) { charid = trie->charmap[ uvc ]; } else { - SV* const * const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0); + SV* const * const svpp = hv_fetch( widecharmap, + (char*)&uvc, + sizeof( UV ), + 0); charid = svpp ? (U16)SvIV(*svpp) : 0; } if ( charid ) { @@ -2388,7 +2529,8 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs } 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 */ + /* charid is now 0 if we dont know the char read, or + * nonzero if we do */ } } accept_state = TRIE_NODENUM( state ); @@ -2475,7 +2617,10 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs U32 used = trie->trans[ stateidx ].check; trie->trans[ stateidx ].check = 0; - for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) { + 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) { @@ -2484,8 +2629,13 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs break; } } - trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ; - trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next ); + 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; @@ -2494,9 +2644,12 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs } if ( !flag ) { flag = 1; - trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ; + trie->states[ state ].trans.base + = pos + trie->uniquecharcount - charid ; } - trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next ); + trie->trans[ pos ].next + = SAFE_TRIE_NODENUM( + trie->trans[ stateidx + charid ].next ); trie->trans[ pos ].check = state; pos++; } @@ -2507,19 +2660,21 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs PerlMemShared_realloc( trie->states, laststate * sizeof(reg_trie_state) ); DEBUG_TRIE_COMPILE_MORE_r( - PerlIO_printf( Perl_debug_log, - "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n", - (int)depth * 2 + 2,"", - (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ), - (IV)next_alloc, - (IV)pos, - ( ( next_alloc - pos ) * 100 ) / (double)next_alloc ); + PerlIO_printf( Perl_debug_log, + "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n", + (int)depth * 2 + 2,"", + (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( - PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n", + PerlIO_printf(Perl_debug_log, + "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n", (int)depth * 2 + 2, "", (UV)trie->statecount, (UV)trie->lasttrans) @@ -2529,10 +2684,10 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs PerlMemShared_realloc( trie->trans, trie->lasttrans * sizeof(reg_trie_trans) ); - { /* Modify the program and insert the new TRIE node */ + { /* Modify the program and insert the new TRIE node */ U8 nodetype =(U8)(flags & 0xFF); char *str=NULL; - + #ifdef DEBUGGING regnode *optimize = NULL; #ifdef RE_TRACK_PATTERN_OFFSETS @@ -2570,12 +2725,13 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs }); } DEBUG_OPTIMISE_r( - PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n", + PerlIO_printf(Perl_debug_log, + "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n", (int)depth * 2 + 2, "", (UV)mjd_offset, (UV)mjd_nodelen) ); #endif - /* But first we check to see if there is a common prefix we can + /* 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 ) { @@ -2634,11 +2790,11 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs PerlIO_printf( Perl_debug_log, "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n", (int)depth * 2 + 2, "", - (UV)state, (UV)idx, - pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6, + (UV)state, (UV)idx, + 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 + PERL_PV_ESCAPE_FIRSTCHAR ) ); }); @@ -2651,7 +2807,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs while (len--) *str++ = *ch++; } else { -#ifdef DEBUGGING +#ifdef DEBUGGING if (state>1) DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n")); #endif @@ -2702,17 +2858,17 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs } } } - if (!jumper) - jumper = last; + 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. + /* 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) + 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 @@ -2727,17 +2883,17 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char); PerlMemShared_free(trie->bitmap); trie->bitmap= NULL; - } else + } else OP( convert ) = TRIE; /* store the type in the flags */ convert->flags = nodetype; DEBUG_r({ - optimize = convert - + NODE_STEP_REGNODE + optimize = convert + + NODE_STEP_REGNODE + regarglen[ OP( convert ) ]; }); - /* XXX We really should free up the resource in trie now, + /* XXX We really should free up the resource in trie now, as we won't use them - (which resources?) dmq */ } /* needed for dumping*/ @@ -2747,8 +2903,8 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs while ( ++opt < optimize) { Set_Node_Offset_Length(opt,0,0); } - /* - Try to clean up some of the debris left after the + /* + Try to clean up some of the debris left after the optimisation. */ while( optimize < jumper ) { @@ -2803,10 +2959,10 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *firs #else SvREFCNT_dec_NN(revcharmap); #endif - return trie->jump - ? MADE_JUMP_TRIE - : trie->startstate>1 - ? MADE_EXACT_TRIE + return trie->jump + ? MADE_JUMP_TRIE + : trie->startstate>1 + ? MADE_EXACT_TRIE : MADE_TRIE; } @@ -2912,7 +3068,7 @@ S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source, regnode fail[ 0 ] = fail[ 1 ] = 0; DEBUG_TRIE_COMPILE_r({ PerlIO_printf(Perl_debug_log, - "%*sStclass Failtable (%"UVuf" states): 0", + "%*sStclass Failtable (%"UVuf" states): 0", (int)(depth * 2), "", (UV)numstates ); for( q_read=1; q_read next) stringok = 0; if (PL_regkind[OP(n)] == NOTHING) { @@ -3086,12 +3265,13 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, UV *min_subtract, b const unsigned int oldl = STR_LEN(scan); regnode * const nnext = regnext(n); - /* XXX I (khw) kind of doubt that this works on platforms where - * U8_MAX is above 255 because of lots of other assumptions */ + /* 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; - + DEBUG_PEEP("merg",n,depth); merged++; @@ -3122,7 +3302,7 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, UV *min_subtract, b } *min_subtract = 0; - *has_exactf_sharp_s = FALSE; + *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 @@ -3130,15 +3310,68 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, UV *min_subtract, b * hence missed). The sequences only happen in folding, hence for any * non-EXACT EXACTish node */ if (OP(scan) != EXACT) { - const U8 * const s0 = (U8*) STRING(scan); - const U8 * s = s0; - const U8 * const s_end = s0 + STR_LEN(scan); + 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 + * 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; + _to_utf8_fold_flags(s, 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 @@ -3146,41 +3379,32 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, UV *min_subtract, b while (s < s_end - 1) /* Can stop 1 before the end, as minimum length sequence we are looking for is 2 */ { - int count = 0; - int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end); + int count = 0; /* How many characters in a multi-char fold */ + int len = is_MULTI_CHAR_FOLD_utf8(s); if (! len) { /* Not a multi-char fold: get next char */ s += UTF8SKIP(s); continue; } - /* Nodes with 'ss' require special handling, except for EXACTFL - * and EXACTFA-ish for which there is no multi-char fold to - * this */ + /* Nodes with 'ss' require special handling, except for + * EXACTFA-ish for which there is no multi-char fold to this */ if (len == 2 && *s == 's' && *(s+1) == 's' - && OP(scan) != EXACTFL && OP(scan) != EXACTFA && OP(scan) != EXACTFA_NO_TRIE) { count = 2; - OP(scan) = EXACTFU_SS; + if (OP(scan) != EXACTFL) { + OP(scan) = EXACTFU_SS; + } s += 2; } else { /* Here is a generic multi-char fold. */ - const U8* multi_end = s + len; - - /* Count how many characters in it. In the case of /l and - * /aa, no folds which contain ASCII code points are - * allowed, so check for those, and skip if found. (In - * EXACTFL, no folds are allowed to any Latin1 code point, - * not just ASCII. But there aren't any of these - * currently, nor ever likely, so don't take the time to - * test for them. The code that generates the - * is_MULTI_foo() macros croaks should one actually get put - * into Unicode .) */ - if (OP(scan) != EXACTFL - && OP(scan) != EXACTFA - && OP(scan) != EXACTFA_NO_TRIE) - { + U8* multi_end = s + len; + + /* Count how many characters 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) != EXACTFA && OP(scan) != EXACTFA_NO_TRIE) { count = utf8_length(s, multi_end); s = multi_end; } @@ -3200,9 +3424,23 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, UV *min_subtract, b /* The delta is how long the sequence is minus 1 (1 is how long * the character that folds to the sequence is) */ - *min_subtract += count - 1; - next_iteration: ; + 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) == EXACTFA) { @@ -3215,32 +3453,32 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, UV *min_subtract, b while (s < s_end) { if (*s == LATIN_SMALL_LETTER_SHARP_S) { OP(scan) = EXACTFA_NO_TRIE; - *has_exactf_sharp_s = TRUE; + *unfolded_multi_char = TRUE; break; } s++; continue; } } - else if (OP(scan) != EXACTFL) { + else { - /* Non-UTF-8 pattern, not EXACTFA nor EXACTFL node. Look for the - * multi-char folds that are all Latin1. (This code knows that - * there are no current multi-char folds possible with EXACTFL, - * relying on fold_grind.t to catch any errors if the very unlikely - * event happens that some get added in future Unicode versions.) - * As explained in the comments preceding this function, we look - * also for the sharp s in EXACTF 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) ? s_end : s_end -1; + /* Non-UTF-8 pattern, not EXACTFA 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); + int len = is_MULTI_CHAR_FOLD_latin1(s); if (! len) { /* Not a multi-char fold. */ - if (*s == LATIN_SMALL_LETTER_SHARP_S && OP(scan) == EXACTF) + if (*s == LATIN_SMALL_LETTER_SHARP_S + && (OP(scan) == EXACTF || OP(scan) == EXACTFL)) { - *has_exactf_sharp_s = TRUE; + *unfolded_multi_char = TRUE; } s++; continue; @@ -3255,8 +3493,9 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, UV *min_subtract, b * 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 is UTF-8, - * which we don't know until runtime */ - if (OP(scan) != EXACTF) { + * which we don't know until runtime. EXACTFL nodes can't + * transform into EXACTFU nodes */ + if (OP(scan) != EXACTF && OP(scan) != EXACTFL) { OP(scan) = EXACTFU_SS; } } @@ -3301,19 +3540,18 @@ typedef struct scan_frame { regnode *last; /* last node to process in this frame */ regnode *next; /* next node to process when last is reached */ struct scan_frame *prev; /*previous frame*/ + U32 prev_recursed_depth; I32 stop; /* what stopparen do we use */ } scan_frame; -#define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf) - STATIC SSize_t S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, SSize_t *minlenp, SSize_t *deltap, regnode *last, scan_data_t *data, I32 stopparen, - U8* recursed, + U32 recursed_depth, regnode_ssc *and_withp, U32 flags, U32 depth) /* scanp: Start here (read-write). */ @@ -3345,14 +3583,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, #ifdef DEBUGGING StructCopy(&zero_scan_data, &data_fake, scan_data_t); #endif - if (!recursed) { - Newxz(recursed, (((RExC_npar + 1)>>3) + 1), U8); - SAVEFREEPV(recursed); - } - if ( depth == 0 ) { - /* Set up a bitmask of which recursive component we have - * already entered. */ while (first_non_open && OP(first_non_open) == OPEN) first_non_open=regnext(first_non_open); } @@ -3363,15 +3594,39 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, 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 has_exactf_sharp_s = FALSE; + bool unfolded_multi_char = FALSE; /* Peephole optimizer: */ - DEBUG_STUDYDATA("Peep:", data,depth); - DEBUG_PEEP("Peep",scan,depth); + DEBUG_OPTIMISE_MORE_r( + { + PerlIO_printf(Perl_debug_log, + "%*sstudy_chunk stopparen=%ld depth=%lu recursed_depth=%lu ", + ((int) depth*2), "", (long)stopparen, + (unsigned long)depth, (unsigned long)recursed_depth); + if (recursed_depth) { + U32 i; + U32 j; + for ( j = 0 ; j < recursed_depth ; j++ ) { + PerlIO_printf(Perl_debug_log,"["); + for ( i = 0 ; i < (U32)RExC_npar ; i++ ) + PerlIO_printf(Perl_debug_log,"%d", + PAREN_TEST(RExC_study_chunk_recursed + + (j * RExC_study_chunk_recursed_bytes), i) + ? 1 : 0 + ); + PerlIO_printf(Perl_debug_log,"]"); + } + } + PerlIO_printf(Perl_debug_log,"\n"); + } + ); + DEBUG_STUDYDATA("Peep:", data, depth); + DEBUG_PEEP("Peep", scan, depth); + /* Its not clear to khw or hv why this is done here, and not in the * clauses that deal with EXACT nodes. khw's guess is that it's * because of a previous design */ - JOIN_EXACT(scan,&min_subtract, &has_exactf_sharp_s, 0); + JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0); /* Follow the next-chain of the current node and optimize away all the NOTHINGs from it. */ @@ -3404,7 +3659,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, || OP(scan) == IFTHEN) { next = regnext(scan); code = OP(scan); - /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */ + /* demq: the op(next)==code check is to see if we have + * "branch-branch" AFAICT */ if (OP(next) == code || code == IFTHEN) { /* NOTE - There is similar code to this block below for @@ -3413,11 +3669,13 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, SSize_t max1 = 0, min1 = SSize_t_MAX, num = 0; regnode_ssc accum; regnode * const startbranch=scan; - U8 *myrecursed= NULL; - if (flags & SCF_DO_SUBSTR) - SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */ - if (flags & SCF_DO_STCLASS) + 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) { @@ -3447,16 +3705,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if (flags & SCF_WHILEM_VISITED_POS) f |= SCF_WHILEM_VISITED_POS; - /* create a new recursed for this branch */ - if (!myrecursed) { - Newx(myrecursed, (((RExC_npar + 1)>>3) + 1), U8); - SAVEFREEPV(myrecursed); - } - Copy(recursed, myrecursed, (((RExC_npar + 1)>>3) + 1), U8); /* we suppose the run is continuous, last=next...*/ - minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, - next, &data_fake, - stopparen, myrecursed, NULL, f,depth+1); + minnext = study_chunk(pRExC_state, &scan, minlenp, + &deltanext, next, &data_fake, stopparen, + recursed_depth, NULL, f,depth+1); if (min1 > minnext) min1 = minnext; if (deltanext == SSize_t_MAX) { @@ -3468,7 +3720,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR)) pars++; if (data_fake.flags & SCF_SEEN_ACCEPT) { - if ( stopmin > minnext) + if ( stopmin > minnext) stopmin = min + min1; flags &= ~SCF_DO_SUBSTR; if (data) @@ -3522,7 +3774,9 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } } - if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) { + if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) + == BRANCH ) + { /* demq. Assuming this was/is a branch we are dealing with: 'scan' @@ -3555,7 +3809,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, 'BRANCH EXACT; BRANCH EXACT; BRANCH X' becomes BRANCH TRIE; BRANCH X; - There is an additional case, that being where there is a + 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. @@ -3581,7 +3835,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, U32 count=0; #ifdef DEBUGGING - SV * const mysv = sv_newmortal(); /* for dumping */ + SV * const mysv = sv_newmortal(); /* for dumping */ #endif /* var tail is used because there may be a TAIL regop in the way. Ie, the exacts will point to the @@ -3596,16 +3850,16 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, tail = regnext( tail ); } - + DEBUG_TRIE_COMPILE_r({ regprop(RExC_rx, mysv, tail ); PerlIO_printf( Perl_debug_log, "%*s%s%s\n", - (int)depth * 2 + 2, "", - "Looking for TRIE'able sequences. Tail node is: ", - SvPV_nolen_const( mysv ) + (int)depth * 2 + 2, "", + "Looking for TRIE'able sequences. Tail node is: ", + SvPV_nolen_const( mysv ) ); }); - + /* Step through the branches @@ -3694,7 +3948,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d,tt==%s,nt==%s,nnt==%s)\n", REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur), - PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype] + PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype] ); }); @@ -3760,8 +4014,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, * so we leave it in for now. */ if ( trietype && trietype != NOTHING ) make_trie( pRExC_state, - startbranch, first, cur, tail, count, - trietype, depth+1 ); + startbranch, first, cur, tail, + count, trietype, depth+1 ); last = NULL; /* note: we clear/update first, trietype etc below, so we dont do it here */ @@ -3789,7 +4043,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, DEBUG_TRIE_COMPILE_r({ regprop(RExC_rx, mysv, cur); PerlIO_printf( Perl_debug_log, - "%*s- %s (%d) \n", (int)depth * 2 + 2, + "%*s- %s (%d) \n", + (int)depth * 2 + 2, "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur)); }); @@ -3798,7 +4053,9 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, /* 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 ); + made= make_trie( pRExC_state, startbranch, + first, scan, tail, count, + trietype, depth+1 ); #ifdef TRIE_STUDY_OPT if ( ((made == MADE_EXACT_TRIE && startbranch == first) @@ -3808,7 +4065,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if ( startbranch == first && scan == tail ) { - RExC_seen &=~REG_TOP_LEVEL_BRANCHES; + RExC_seen &=~REG_TOP_LEVEL_BRANCHES_SEEN; } } #endif @@ -3838,9 +4095,9 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } } /* end if ( last) */ } /* TRIE_MAXBUF is non zero */ - + } /* do trie */ - + } else if ( code == BRANCHJ ) { /* single branch is optimized. */ scan = NEXTOPER(NEXTOPER(scan)); @@ -3852,9 +4109,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 paren; regnode *start; regnode *end; + U32 my_recursed_depth= recursed_depth; if (OP(scan) != SUSPEND) { - /* set the pointer */ + /* set the pointer */ if (OP(scan) == GOSUB) { paren = ARG(scan); RExC_recurse[ARG2L(scan)] = scan; @@ -3865,17 +4123,28 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, start = RExC_rxi->program + 1; end = RExC_opend; } - - if (!PAREN_TEST(recursed,paren)) { + if (!recursed_depth + || + !PAREN_TEST(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes), paren) + ) { + if (!recursed_depth) { + Zero(RExC_study_chunk_recursed, RExC_study_chunk_recursed_bytes, U8); + } else { + Copy(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes), + RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes), + RExC_study_chunk_recursed_bytes, U8); + } /* we havent recursed into this paren yet, so recurse into it */ DEBUG_STUDYDATA("set:", data,depth); - PAREN_SET(recursed, paren); + PAREN_SET(RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes), paren); + my_recursed_depth= recursed_depth + 1; Newx(newframe,1,scan_frame); } else { DEBUG_STUDYDATA("inf:", data,depth); - /* some form of infinite recursion, assume infinite length */ + /* some form of infinite recursion, assume infinite length + * */ if (flags & SCF_DO_SUBSTR) { - SCAN_COMMIT(pRExC_state,data,minlenp); + scan_commit(pRExC_state, data, minlenp, is_inf); data->longest = &(data->longest_float); } is_inf = is_inf_internal = 1; @@ -3897,11 +4166,17 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, newframe->last = last; newframe->stop = stopparen; newframe->prev = frame; + newframe->prev_recursed_depth = recursed_depth; + + DEBUG_STUDYDATA("frame-new:",data,depth); + DEBUG_PEEP("fnew", scan, depth); frame = newframe; scan = start; stopparen = paren; last = end; + depth = depth + 1; + recursed_depth= my_recursed_depth; continue; } @@ -3934,7 +4209,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, mg_find(sv, PERL_MAGIC_utf8) : NULL; if (mg && mg->mg_len >= 0) mg->mg_len += utf8_length((U8*)STRING(scan), - (U8*)STRING(scan)+STR_LEN(scan)); + (U8*)STRING(scan)+STR_LEN(scan)); } data->last_end = data->pos_min + l; data->pos_min += l; /* As in the first entry. */ @@ -3951,6 +4226,9 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, else if (flags & SCF_DO_STCLASS_OR) { ssc_add_cp(data->start_class, uc); ssc_and(pRExC_state, data->start_class, and_withp); + + /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */ + ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING; } flags &= ~SCF_DO_STCLASS; } @@ -3963,15 +4241,15 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, /* Search for fixed substrings supports EXACT only. */ if (flags & SCF_DO_SUBSTR) { assert(data); - SCAN_COMMIT(pRExC_state, data, minlenp); + scan_commit(pRExC_state, data, minlenp, is_inf); } if (UTF) { const U8 * const s = (U8 *)STRING(scan); uc = utf8_to_uvchr_buf(s, s + l, NULL); l = utf8_length(s, s + l); } - if (has_exactf_sharp_s) { - RExC_seen |= REG_SEEN_EXACTF_SHARP_S; + if (unfolded_multi_char) { + RExC_seen |= REG_UNFOLDED_MULTI_SEEN; } min += l - min_subtract; assert (min >= 0); @@ -3988,12 +4266,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } if (OP(scan) == EXACTFL) { if (flags & SCF_DO_STCLASS_AND) { - ssc_flags_and(data->start_class, - ANYOF_LOCALE|ANYOF_LOC_FOLD); + ssc_flags_and(data->start_class, ANYOF_LOCALE); } else if (flags & SCF_DO_STCLASS_OR) { - ANYOF_FLAGS(data->start_class) - |= ANYOF_LOCALE|ANYOF_LOC_FOLD; + ANYOF_FLAGS(data->start_class) |= ANYOF_LOCALE; } /* We don't know what the folds are; it could be anything. XXX @@ -4053,7 +4329,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, * range can participate */ if (OP(scan) == EXACTFA) { _invlist_union_complement_2nd(EXACTF_invlist, - PL_Posix_ptrs[_CC_ASCII], + PL_XPosix_ptrs[_CC_ASCII], &EXACTF_invlist); } else { @@ -4070,6 +4346,9 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, else if (flags & SCF_DO_STCLASS_OR) { ssc_union(data->start_class, EXACTF_invlist, FALSE); ssc_and(pRExC_state, data->start_class, and_withp); + + /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */ + ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING; } flags &= ~SCF_DO_STCLASS; SvREFCNT_dec(EXACTF_invlist); @@ -4109,12 +4388,13 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, scan = NEXTOPER(scan); goto do_curly; } - is_inf = is_inf_internal = 1; - scan = regnext(scan); if (flags & SCF_DO_SUBSTR) { - SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */ + scan_commit(pRExC_state, data, minlenp, is_inf); + /* Cannot extend fixed substrings */ data->longest = &(data->longest_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) @@ -4135,7 +4415,9 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, next_is_eval = (OP(scan) == EVAL); do_curly: if (flags & SCF_DO_SUBSTR) { - if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */ + if (mincount == 0) + scan_commit(pRExC_state, data, minlenp, is_inf); + /* Cannot extend fixed substrings */ pos_before = data->pos_min; } if (data) { @@ -4164,10 +4446,12 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, f &= ~SCF_WHILEM_VISITED_POS; /* This will finish on WHILEM, setting scan, or on NULL: */ - minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, - last, data, stopparen, recursed, NULL, - (mincount == 0 - ? (f & ~SCF_DO_SUBSTR) : f),depth+1); + minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, + last, data, stopparen, recursed_depth, NULL, + (mincount == 0 + ? (f & ~SCF_DO_SUBSTR) + : f) + ,depth+1); if (flags & SCF_DO_STCLASS) data->start_class = oclass; @@ -4201,24 +4485,26 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, && (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 */ + && maxcount <= REG_INFTY/3) /* Complement check for big + count */ { /* Fatal warnings may leak the regexp without this: */ SAVEFREESV(RExC_rx_sv); ckWARNreg(RExC_parse, - "Quantifier unexpected on zero-length expression"); + "Quantifier unexpected on zero-length expression"); (void)ReREFCNT_inc(RExC_rx_sv); } min += minnext * mincount; is_inf_internal |= deltanext == SSize_t_MAX - || (maxcount == REG_INFTY && minnext + deltanext > 0); + || (maxcount == REG_INFTY && minnext + deltanext > 0); is_inf |= is_inf_internal; - if (is_inf) + if (is_inf) { delta = SSize_t_MAX; - else - delta += (minnext + deltanext) * maxcount - minnext * mincount; - + } else { + delta += (minnext + deltanext) * maxcount + - minnext * mincount; + } /* Try powerful optimization CURLYX => CURLYN. */ if ( OP(oscan) == CURLYX && data && data->flags & SF_IN_PAR @@ -4269,7 +4555,10 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, && !(data->flags & SF_HAS_EVAL) && !deltanext /* atom is fixed width */ && minnext != 0 /* CURLYM can't handle zero width */ - && ! (RExC_seen & REG_SEEN_EXACTF_SHARP_S) /* Nor \xDF */ + + /* Nor characters whose fold at run-time may be + * multi-character */ + && ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN) ) { /* XXXX How to optimize if data == 0? */ /* Optimize to a simpler form. */ @@ -4316,7 +4605,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, #endif /* Optimize again: */ study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt, - NULL, stopparen, recursed, NULL, 0,depth+1); + NULL, stopparen, recursed_depth, NULL, 0,depth+1); } else oscan->flags = 0; @@ -4341,9 +4630,11 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, 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. */ + 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; @@ -4355,12 +4646,16 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, 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); + SvPVX_const(last_str), l, + mincount - 1); SvCUR_set(last_str, SvCUR(last_str) * mincount); /* Add additional parts. */ SvCUR_set(data->last_found, @@ -4372,8 +4667,9 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; if (mg && mg->mg_len >= 0) - mg->mg_len += CHR_SVLEN(last_str) - l; + mg->mg_len += last_chrs * (mincount-1); } + last_chrs *= mincount; data->last_end += l * (mincount - 1); } } else { @@ -4396,8 +4692,8 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", (UV)(-counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount), (UV)(SSize_t_MAX - data->pos_delta)); #endif - if (deltanext == SSize_t_MAX || - -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= SSize_t_MAX - data->pos_delta) + if (deltanext == SSize_t_MAX + || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= SSize_t_MAX - data->pos_delta) data->pos_delta = SSize_t_MAX; else data->pos_delta += - counted * deltanext + @@ -4405,7 +4701,7 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", if (mincount != maxcount) { /* Cannot extend fixed substrings found inside the group. */ - SCAN_COMMIT(pRExC_state,data,minlenp); + 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) ? @@ -4415,12 +4711,10 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", mg->mg_len = -1; sv_setsv(sv, last_str); data->last_end = data->pos_min; - data->last_start_min = - data->pos_min - CHR_SVLEN(last_str); + data->last_start_min = data->pos_min - last_chrs; data->last_start_max = is_inf ? SSize_t_MAX - : data->pos_min + data->pos_delta - - CHR_SVLEN(last_str); + : data->pos_min + data->pos_delta - last_chrs; } data->longest = &(data->longest_float); } @@ -4444,7 +4738,8 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", case REF: case CLUMP: if (flags & SCF_DO_SUBSTR) { - SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */ + /* Cannot expect anything... */ + scan_commit(pRExC_state, data, minlenp, is_inf); data->longest = &(data->longest_float); } is_inf = is_inf_internal = 1; @@ -4475,13 +4770,18 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", PL_XPosix_ptrs[_CC_VERTSPACE], FALSE); ssc_and(pRExC_state, data->start_class, and_withp); + + /* See commit msg for + * 749e076fceedeb708a624933726e7989f2302f6a */ + ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING; } flags &= ~SCF_DO_STCLASS; } min++; delta++; /* Because of the 2 char string cr-lf */ if (flags & SCF_DO_SUBSTR) { - SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */ + /* Cannot expect anything... */ + scan_commit(pRExC_state, data, minlenp, is_inf); data->pos_min += 1; data->pos_delta += 1; data->longest = &(data->longest_float); @@ -4490,19 +4790,17 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", else if (REGNODE_SIMPLE(OP(scan))) { if (flags & SCF_DO_SUBSTR) { - SCAN_COMMIT(pRExC_state,data,minlenp); + scan_commit(pRExC_state, data, minlenp, is_inf); data->pos_min++; } min++; if (flags & SCF_DO_STCLASS) { bool invert = 0; SV* my_invlist = sv_2mortal(_new_invlist(0)); - U8 classnum; U8 namedclass; - if (flags & SCF_DO_STCLASS_AND) { - ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING; - } + /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */ + ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING; /* Some of the logic below assumes that switching locale on will only add false positives. */ @@ -4510,7 +4808,8 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", default: #ifdef DEBUGGING - Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); + Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", + OP(scan)); #endif case CANY: case SANY: @@ -4541,7 +4840,7 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", } break; - case ANYOF_WARN_SUPER: + case ANYOF_NON_UTF8_NON_ASCII_ALL: case ANYOF: if (flags & SCF_DO_STCLASS_AND) ssc_and(pRExC_state, data->start_class, @@ -4556,8 +4855,7 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", /* FALL THROUGH */ case POSIXL: - classnum = FLAGS(scan); - namedclass = classnum_to_namedclass(classnum) + invert; + namedclass = classnum_to_namedclass(FLAGS(scan)) + invert; if (flags & SCF_DO_STCLASS_AND) { bool was_there = cBOOL( ANYOF_POSIXL_TEST(data->start_class, @@ -4603,8 +4901,14 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", invert = 1; /* FALL THROUGH */ case POSIXA: - classnum = FLAGS(scan); - my_invlist = PL_Posix_ptrs[classnum]; + if (FLAGS(scan) == _CC_ASCII) { + my_invlist = PL_XPosix_ptrs[_CC_ASCII]; + } + else { + _invlist_intersection(PL_XPosix_ptrs[FLAGS(scan)], + PL_XPosix_ptrs[_CC_ASCII], + &my_invlist); + } goto join_posix; case NPOSIXD: @@ -4613,25 +4917,16 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", /* FALL THROUGH */ case POSIXD: case POSIXU: - classnum = FLAGS(scan); - - /* If we know all the code points that match the class, use - * that; otherwise use the Latin1 code points, plus we have - * to assume that it could match anything above Latin1 */ - if (PL_XPosix_ptrs[classnum]) { - my_invlist = invlist_clone(PL_XPosix_ptrs[classnum]); - } - else { - _invlist_union(PL_L1Posix_ptrs[classnum], - PL_AboveLatin1, &my_invlist); - } + my_invlist = invlist_clone(PL_XPosix_ptrs[FLAGS(scan)]); /* NPOSIXD matches all upper Latin1 code points unless the * target string being matched is UTF-8, which is - * unknowable until match time */ - if (PL_regkind[OP(scan)] == NPOSIXD) { - _invlist_union_complement_2nd(my_invlist, - PL_Posix_ptrs[_CC_ASCII], &my_invlist); + * 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: @@ -4654,7 +4949,7 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", data->flags |= (OP(scan) == MEOL ? SF_BEFORE_MEOL : SF_BEFORE_SEOL); - SCAN_COMMIT(pRExC_state, data, minlenp); + scan_commit(pRExC_state, data, minlenp, is_inf); } else if ( PL_regkind[OP(scan)] == BRANCHJ @@ -4674,10 +4969,11 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", /*DEBUG_PARSE_MSG("opfail");*/ regprop(RExC_rx, mysv_val, upto); - PerlIO_printf(Perl_debug_log, "~ replace with OPFAIL pointed at %s (%"IVdf") offset %"IVdf"\n", - SvPV_nolen_const(mysv_val), - (IV)REG_NODE_NUM(upto), - (IV)(upto - scan) + PerlIO_printf(Perl_debug_log, + "~ replace with OPFAIL pointed at %s (%"IVdf") offset %"IVdf"\n", + SvPV_nolen_const(mysv_val), + (IV)REG_NODE_NUM(upto), + (IV)(upto - scan) ); }); OP(scan) = OPFAIL; @@ -4687,7 +4983,7 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", scan= upto; continue; } - if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY + if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY || OP(scan) == UNLESSM ) { /* Negative Lookahead/lookbehind @@ -4717,14 +5013,16 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", f |= SCF_WHILEM_VISITED_POS; next = regnext(scan); nscan = NEXTOPER(NEXTOPER(scan)); - minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext, - last, &data_fake, stopparen, recursed, NULL, f, depth+1); + minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext, + last, &data_fake, stopparen, + recursed_depth, NULL, f, depth+1); if (scan->flags) { if (deltanext) { FAIL("Variable length lookbehind not implemented"); } else if (minnext > (I32)U8_MAX) { - FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX); + FAIL2("Lookbehind longer than %"UVuf" not implemented", + (UV)U8_MAX); } scan->flags = (U8)minnext; } @@ -4763,8 +5061,8 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", regnode *nscan; regnode_ssc intrnl; int f = 0; - /* We use SAVEFREEPV so that when the full compile - is finished perl will clean up the allocated + /* 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. @@ -4777,8 +5075,8 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", 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); + if (scan->flags) + scan_commit(pRExC_state, &data_fake, minlenp, is_inf); data_fake.last_found=newSVsv(data->last_found); } } @@ -4799,14 +5097,17 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", next = regnext(scan); nscan = NEXTOPER(NEXTOPER(scan)); - *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext, - last, &data_fake, stopparen, recursed, NULL, f,depth+1); + *minnextp = study_chunk(pRExC_state, &nscan, minnextp, + &deltanext, last, &data_fake, + stopparen, recursed_depth, NULL, + f,depth+1); if (scan->flags) { if (deltanext) { FAIL("Variable length lookbehind not implemented"); } else if (*minnextp > (I32)U8_MAX) { - FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX); + FAIL2("Lookbehind longer than %"UVuf" not implemented", + (UV)U8_MAX); } scan->flags = (U8)*minnextp; } @@ -4825,10 +5126,10 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) { if (RExC_rx->minlen<*minnextp) RExC_rx->minlen=*minnextp; - SCAN_COMMIT(pRExC_state, &data_fake, minnextp); + scan_commit(pRExC_state, &data_fake, minnextp, is_inf); SvREFCNT_dec_NN(data_fake.last_found); - - if ( data_fake.minlen_fixed != minlenp ) + + if ( data_fake.minlen_fixed != minlenp ) { data->offset_fixed= data_fake.offset_fixed; data->minlen_fixed= data_fake.minlen_fixed; @@ -4869,7 +5170,7 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", } else if ( PL_regkind[OP(scan)] == ENDLIKE ) { if (flags & SCF_DO_SUBSTR) { - SCAN_COMMIT(pRExC_state,data,minlenp); + scan_commit(pRExC_state, data, minlenp, is_inf); flags &= ~SCF_DO_SUBSTR; } if (data && OP(scan)==ACCEPT) { @@ -4881,7 +5182,7 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */ { if (flags & SCF_DO_SUBSTR) { - SCAN_COMMIT(pRExC_state,data,minlenp); + scan_commit(pRExC_state, data, minlenp, is_inf); data->longest = &(data->longest_float); } is_inf = is_inf_internal = 1; @@ -4890,17 +5191,17 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", flags &= ~SCF_DO_STCLASS; } else if (OP(scan) == GPOS) { - if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) && - !(delta || is_inf || (data && data->pos_delta))) + if (!(RExC_rx->intflags & PREGf_GPOS_FLOAT) && + !(delta || is_inf || (data && data->pos_delta))) { - if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR)) - RExC_rx->extflags |= RXf_ANCH_GPOS; + 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->extflags |= RXf_GPOS_FLOAT; + RExC_rx->intflags |= PREGf_GPOS_FLOAT; RExC_rx->gofs = 0; - } + } } #ifdef TRIE_STUDY_OPT #ifdef FULL_TRIE_STUDY @@ -4914,23 +5215,25 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", SSize_t max1 = 0, min1 = SSize_t_MAX; regnode_ssc accum; - if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */ - SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */ + 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++) + + for ( word=1 ; word <= trie->wordcount ; word++) { SSize_t deltanext=0, minnext=0, f = 0, fake; regnode_ssc this_class; - + data_fake.flags = 0; if (data) { data_fake.whilem_c = data->whilem_c; @@ -4946,22 +5249,21 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", } 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. - */ - minnext = study_chunk(pRExC_state, &scan, minlenp, - &deltanext, (regnode *)nextbranch, &data_fake, - stopparen, recursed, NULL, f,depth+1); + it. Note this means we need the vestigal unused + branches even though they arent otherwise used. */ + minnext = study_chunk(pRExC_state, &scan, minlenp, + &deltanext, (regnode *)nextbranch, &data_fake, + stopparen, recursed_depth, NULL, f,depth+1); } if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH) nextbranch= regnext((regnode*)nextbranch); - + if (min1 > (SSize_t)(minnext + trie->minlen)) min1 = minnext + trie->minlen; if (deltanext == SSize_t_MAX) { @@ -4969,11 +5271,11 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", max1 = SSize_t_MAX; } 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) + if ( stopmin > min + min1) stopmin = min + min1; flags &= ~SCF_DO_SUBSTR; if (data) @@ -5025,19 +5327,20 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", else if (PL_regkind[OP(scan)] == TRIE) { reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ]; U8*bang=NULL; - + min += trie->minlen; delta += (trie->maxlen - trie->minlen); flags &= ~SCF_DO_STCLASS; /* xxx */ if (flags & SCF_DO_SUBSTR) { - SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */ + /* 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->longest = &(data->longest_float); } if (trie->jump) /* no more substrings -- for now /grr*/ - flags &= ~SCF_DO_SUBSTR; + flags &= ~SCF_DO_SUBSTR; } #endif /* old or new */ #endif /* TRIE_STUDY_OPT */ @@ -5047,15 +5350,22 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", } /* If we are exiting a recursion we can unset its recursed bit * and allow ourselves to enter it again - no danger of an - * infinite loop there. */ + * infinite loop there. if (stopparen > -1 && recursed) { DEBUG_STUDYDATA("unset:", data,depth); PAREN_UNSET( recursed, stopparen); } + */ if (frame) { + DEBUG_STUDYDATA("frame-end:",data,depth); + DEBUG_PEEP("fend", scan, depth); + /* restore previous context */ last = frame->last; scan = frame->next; stopparen = frame->stop; + recursed_depth = frame->prev_recursed_depth; + depth = depth - 1; + frame = frame->prev; goto fake_study_recurse; } @@ -5066,6 +5376,7 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", *scanp = scan; *deltap = is_inf_internal ? SSize_t_MAX : delta; + if (flags & SCF_DO_SUBSTR && is_inf) data->pos_delta = SSize_t_MAX - data->pos_min; if (is_par > (I32)U8_MAX) @@ -5082,10 +5393,18 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVdf" RHS=%"UVdf"\n", ssc_and(pRExC_state, data->start_class, and_withp); if (flags & SCF_TRIE_RESTUDY) data->flags |= SCF_TRIE_RESTUDY; - + DEBUG_STUDYDATA("post-fin:",data,depth); - - return min < stopmin ? min : stopmin; + + { + SSize_t final_minlen= min < stopmin ? min : stopmin; + + if (!(RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) && (RExC_maxlen < final_minlen + delta)) { + RExC_maxlen = final_minlen + delta; + } + return final_minlen; + } + /* not-reached */ } STATIC U32 @@ -5150,7 +5469,7 @@ Perl_reginitcolors(pTHX) } STMT_END #else #define CHECK_RESTUDY_GOTO_butfirst -#endif +#endif /* * pregcomp - compile a regular expression into internal code @@ -5159,7 +5478,7 @@ Perl_reginitcolors(pTHX) * scope */ -#ifndef PERL_IN_XSUB_RE +#ifndef PERL_IN_XSUB_RE /* return the currently in-scope regex engine (or the default if none) */ @@ -5345,7 +5664,7 @@ S_concat_pat(pTHX_ RExC_state_t * const pRExC_state, if (oplist) { assert(oplist->op_type == OP_PADAV - || oplist->op_type == OP_RV2AV); + || oplist->op_type == OP_RV2AV); oplist = oplist->op_sibling;; } @@ -5735,8 +6054,10 @@ S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state, STATIC bool -S_setup_longest(pTHX_ RExC_state_t *pRExC_state, SV* sv_longest, SV** rx_utf8, SV** rx_substr, SSize_t* rx_end_shift, - SSize_t lookbehind, SSize_t offset, SSize_t *minlen, STRLEN longest_length, bool eol, bool meol) +S_setup_longest(pTHX_ RExC_state_t *pRExC_state, SV* sv_longest, + SV** rx_utf8, SV** rx_substr, SSize_t* rx_end_shift, + SSize_t lookbehind, SSize_t offset, SSize_t *minlen, + STRLEN longest_length, bool eol, bool meol) { /* This is the common code for setting up the floating and fixed length * string data extracted from Perl_re_op_compile() below. Returns a boolean @@ -5749,8 +6070,8 @@ S_setup_longest(pTHX_ RExC_state_t *pRExC_state, SV* sv_longest, SV** rx_utf8, S || (eol /* Can't have SEOL and MULTI */ && (! meol || (RExC_flags & RXf_PMf_MULTILINE))) ) - /* See comments for join_exact for why REG_SEEN_EXACTF_SHARP_S */ - || (RExC_seen & REG_SEEN_EXACTF_SHARP_S)) + /* See comments for join_exact for why REG_UNFOLDED_MULTI_SEEN */ + || (RExC_seen & REG_UNFOLDED_MULTI_SEEN)) { return FALSE; } @@ -5856,10 +6177,10 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, scan_data_t data; RExC_state_t RExC_state; RExC_state_t * const pRExC_state = &RExC_state; -#ifdef TRIE_STUDY_OPT +#ifdef TRIE_STUDY_OPT int restudied = 0; RExC_state_t copyRExC_state; -#endif +#endif GET_RE_DEBUG_FLAGS_DECL; PERL_ARGS_ASSERT_RE_OP_COMPILE; @@ -5873,63 +6194,9 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist); PL_Latin1 = _new_invlist_C_array(Latin1_invlist); PL_UpperLatin1 = _new_invlist_C_array(UpperLatin1_invlist); - - PL_Posix_ptrs[_CC_ASCII] = _new_invlist_C_array(ASCII_invlist); - PL_L1Posix_ptrs[_CC_ASCII] = _new_invlist_C_array(ASCII_invlist); - PL_XPosix_ptrs[_CC_ASCII] = _new_invlist_C_array(ASCII_invlist); - - PL_L1Posix_ptrs[_CC_ALPHANUMERIC] - = _new_invlist_C_array(L1PosixAlnum_invlist); - PL_Posix_ptrs[_CC_ALPHANUMERIC] - = _new_invlist_C_array(PosixAlnum_invlist); - - PL_L1Posix_ptrs[_CC_ALPHA] - = _new_invlist_C_array(L1PosixAlpha_invlist); - PL_Posix_ptrs[_CC_ALPHA] = _new_invlist_C_array(PosixAlpha_invlist); - - PL_Posix_ptrs[_CC_BLANK] = _new_invlist_C_array(PosixBlank_invlist); - PL_XPosix_ptrs[_CC_BLANK] = _new_invlist_C_array(XPosixBlank_invlist); - - /* Cased is the same as Alpha in the ASCII range */ - PL_L1Posix_ptrs[_CC_CASED] = _new_invlist_C_array(L1Cased_invlist); - PL_Posix_ptrs[_CC_CASED] = _new_invlist_C_array(PosixAlpha_invlist); - - PL_Posix_ptrs[_CC_CNTRL] = _new_invlist_C_array(PosixCntrl_invlist); - PL_XPosix_ptrs[_CC_CNTRL] = _new_invlist_C_array(XPosixCntrl_invlist); - - PL_Posix_ptrs[_CC_DIGIT] = _new_invlist_C_array(PosixDigit_invlist); - PL_L1Posix_ptrs[_CC_DIGIT] = _new_invlist_C_array(PosixDigit_invlist); - - PL_L1Posix_ptrs[_CC_GRAPH] = _new_invlist_C_array(L1PosixGraph_invlist); - PL_Posix_ptrs[_CC_GRAPH] = _new_invlist_C_array(PosixGraph_invlist); - - PL_L1Posix_ptrs[_CC_LOWER] = _new_invlist_C_array(L1PosixLower_invlist); - PL_Posix_ptrs[_CC_LOWER] = _new_invlist_C_array(PosixLower_invlist); - - PL_L1Posix_ptrs[_CC_PRINT] = _new_invlist_C_array(L1PosixPrint_invlist); - PL_Posix_ptrs[_CC_PRINT] = _new_invlist_C_array(PosixPrint_invlist); - - PL_L1Posix_ptrs[_CC_PUNCT] = _new_invlist_C_array(L1PosixPunct_invlist); - PL_Posix_ptrs[_CC_PUNCT] = _new_invlist_C_array(PosixPunct_invlist); - - PL_Posix_ptrs[_CC_SPACE] = _new_invlist_C_array(PerlSpace_invlist); - PL_XPosix_ptrs[_CC_SPACE] = _new_invlist_C_array(XPerlSpace_invlist); - PL_Posix_ptrs[_CC_PSXSPC] = _new_invlist_C_array(PosixSpace_invlist); - PL_XPosix_ptrs[_CC_PSXSPC] = _new_invlist_C_array(XPosixSpace_invlist); - - PL_L1Posix_ptrs[_CC_UPPER] = _new_invlist_C_array(L1PosixUpper_invlist); - PL_Posix_ptrs[_CC_UPPER] = _new_invlist_C_array(PosixUpper_invlist); - - PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(VertSpace_invlist); - - PL_Posix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(PosixWord_invlist); - PL_L1Posix_ptrs[_CC_WORDCHAR] - = _new_invlist_C_array(L1PosixWord_invlist); - - PL_Posix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(PosixXDigit_invlist); - PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(XPosixXDigit_invlist); - - PL_HasMultiCharFold = _new_invlist_C_array(_Perl_Multi_Char_Folds_invlist); + PL_utf8_foldable = _new_invlist_C_array(_Perl_Any_Folds_invlist); + PL_HasMultiCharFold = + _new_invlist_C_array(_Perl_Folds_To_Multi_Char_invlist); } #endif @@ -6067,11 +6334,11 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen); /* return old regex if pattern hasn't changed */ - /* XXX: note in the below we have to check the flags as well as the pattern. + /* XXX: note in the below we have to check the flags as well as the + * pattern. * - * Things get a touch tricky as we have to compare the utf8 flag independently - * from the compile flags. - */ + * Things get a touch tricky as we have to compare the utf8 flag + * independently from the compile flags. */ if ( old_re && !recompile @@ -6122,6 +6389,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, RExC_sawback = 0; RExC_seen = 0; + RExC_maxlen = 0; RExC_in_lookbehind = 0; RExC_seen_zerolen = *exp == '^' ? -1 : 0; RExC_extralen = 0; @@ -6146,6 +6414,8 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, RExC_paren_name_list = NULL; #endif RExC_recurse = NULL; + RExC_study_chunk_recursed = NULL; + RExC_study_chunk_recursed_bytes= 0; RExC_recurse_count = 0; pRExC_state->code_index = 0; @@ -6189,12 +6459,12 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, SvLEN_set(code_blocksv,0); /* no you can't have it, sv_clear */ DEBUG_PARSE_r({ - PerlIO_printf(Perl_debug_log, + PerlIO_printf(Perl_debug_log, "Required size %"IVdf" nodes\n" - "Starting second pass (creation)\n", + "Starting second pass (creation)\n", (IV)RExC_size); - RExC_lastnum=0; - RExC_lastparse=NULL; + RExC_lastnum=0; + RExC_lastparse=NULL; }); /* The first pass could have found things that force Unicode semantics */ @@ -6213,8 +6483,8 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, if (RExC_whilem_seen > 15) RExC_whilem_seen = 15; - /* Allocate space and zero-initialize. Note, the two step process - of zeroing when in debug mode, thus anything assigned has to + /* Allocate space and zero-initialize. Note, the two step process + of zeroing when in debug mode, thus anything assigned has to happen after that */ rx = (REGEXP*) newSV_type(SVt_REGEXP); r = ReANY(rx); @@ -6224,10 +6494,11 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, FAIL("Regexp out of space"); #ifdef DEBUGGING /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */ - Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char); -#else + Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), + char); +#else /* bulk initialize base fields with 0. */ - Zero(ri, sizeof(regexp_internal), char); + Zero(ri, sizeof(regexp_internal), char); #endif /* non-zero initialization begins here */ @@ -6251,14 +6522,16 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, { bool has_p = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY); - bool has_charset = (get_regex_charset(r->extflags) != REGEX_DEPENDS_CHARSET); + bool has_charset = (get_regex_charset(r->extflags) + != REGEX_DEPENDS_CHARSET); /* The caret is output if there are any defaults: if not all the STD * flags are set, or if no character set specifier is needed */ bool has_default = (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD) || ! has_charset); - bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT); + bool has_runon = ((RExC_seen & REG_RUN_ON_COMMENT_SEEN) + == REG_RUN_ON_COMMENT_SEEN); U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD) >> RXf_PMf_STD_PMMOD_SHIFT); const char *fptr = STD_PAT_MODS; /*"msix"*/ @@ -6319,13 +6592,24 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, r->intflags = 0; r->nparens = RExC_npar - 1; /* set early to validate backrefs */ - - if (RExC_seen & REG_SEEN_RECURSE) { + + /* setup various meta data about recursion, this all requires + * RExC_npar to be correctly set, and a bit later on we clear it */ + if (RExC_seen & REG_RECURSE_SEEN) { Newxz(RExC_open_parens, RExC_npar,regnode *); SAVEFREEPV(RExC_open_parens); Newxz(RExC_close_parens,RExC_npar,regnode *); SAVEFREEPV(RExC_close_parens); } + if (RExC_seen & (REG_RECURSE_SEEN | REG_GOSTART_SEEN)) { + /* Note, RExC_npar is 1 + the number of parens in a pattern. + * So its 1 if there are no parens. */ + RExC_study_chunk_recursed_bytes= (RExC_npar >> 3) + + ((RExC_npar & 0x07) != 0); + Newx(RExC_study_chunk_recursed, + RExC_study_chunk_recursed_bytes * RExC_npar, U8); + SAVEFREEPV(RExC_study_chunk_recursed); + } /* Useful during FAIL. */ #ifdef RE_TRACK_PATTERN_OFFSETS @@ -6354,7 +6638,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, REGC((U8)REG_MAGIC, (char*) RExC_emit++); if (reg(pRExC_state, 0, &flags,1) == NULL) { - ReREFCNT_dec(rx); + ReREFCNT_dec(rx); Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for generation pass, flags=%#"UVxf"", (UV) flags); } /* XXXX To minimize changes to RE engine we always allocate @@ -6368,6 +6652,9 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, reStudy: r->minlen = minlen = sawlookahead = sawplus = sawopen = sawminmod = 0; Zero(r->substrs, 1, struct reg_substr_data); + if (RExC_study_chunk_recursed) + Zero(RExC_study_chunk_recursed, + RExC_study_chunk_recursed_bytes * RExC_npar, U8); #ifdef TRIE_STUDY_OPT if (!restudied) { @@ -6376,22 +6663,22 @@ reStudy: } else { U32 seen=RExC_seen; DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n")); - + RExC_state = copyRExC_state; - if (seen & REG_TOP_LEVEL_BRANCHES) - RExC_seen |= REG_TOP_LEVEL_BRANCHES; + if (seen & REG_TOP_LEVEL_BRANCHES_SEEN) + RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN; else - RExC_seen &= ~REG_TOP_LEVEL_BRANCHES; + RExC_seen &= ~REG_TOP_LEVEL_BRANCHES_SEEN; StructCopy(&zero_scan_data, &data, scan_data_t); } #else StructCopy(&zero_scan_data, &data, scan_data_t); -#endif +#endif /* Dig out information for optimizations. */ r->extflags = RExC_flags; /* was pm_op */ /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */ - + if (UTF) SvUTF8_on(rx); /* Unicode in it? */ ri->regstclass = NULL; @@ -6401,7 +6688,8 @@ reStudy: /* testing for BRANCH here tells us whether there is "must appear" data in the pattern. If there is then we can use it for optimisations */ - if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /* Only one top-level choice. */ + if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)) { /* Only one top-level choice. + */ SSize_t fake; STRLEN longest_float_length, longest_fixed_length; regnode_ssc ch_class; /* pointed to by data */ @@ -6411,10 +6699,10 @@ reStudy: regnode *first_next= regnext(first); /* * Skip introductions and multiplicators >= 1 - * so that we can extract the 'meat' of the pattern that must + * so that we can extract the 'meat' of the pattern that must * match in the large if() sequence following. * NOTE that EXACT is NOT covered here, as it is normally - * picked up by the optimiser separately. + * picked up by the optimiser separately. * * This is unfortunate as the optimiser isnt handling lookahead * properly currently. @@ -6431,7 +6719,7 @@ reStudy: (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) || (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END )) { - /* + /* * the only op that could be a regnode is PLUS, all the rest * will be regnode_1 or regnode_2. * @@ -6460,7 +6748,7 @@ reStudy: } #ifdef TRIE_STCLASS else if (PL_regkind[OP(first)] == TRIE && - ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0) + ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0) { regnode *trie_op; /* this can happen only on restudy */ @@ -6486,35 +6774,35 @@ reStudy: PL_regkind[OP(first)] == NBOUND) ri->regstclass = first; else if (PL_regkind[OP(first)] == BOL) { - r->extflags |= (OP(first) == MBOL - ? RXf_ANCH_MBOL + r->intflags |= (OP(first) == MBOL + ? PREGf_ANCH_MBOL : (OP(first) == SBOL - ? RXf_ANCH_SBOL - : RXf_ANCH_BOL)); + ? PREGf_ANCH_SBOL + : PREGf_ANCH_BOL)); first = NEXTOPER(first); goto again; } else if (OP(first) == GPOS) { - r->extflags |= RXf_ANCH_GPOS; + r->intflags |= PREGf_ANCH_GPOS; first = NEXTOPER(first); goto again; } else if ((!sawopen || !RExC_sawback) && (OP(first) == STAR && PL_regkind[OP(NEXTOPER(first))] == REG_ANY) && - !(r->extflags & RXf_ANCH) && !pRExC_state->num_code_blocks) + !(r->intflags & PREGf_ANCH) && !pRExC_state->num_code_blocks) { /* turn .* into ^.* with an implied $*=1 */ const int type = (OP(NEXTOPER(first)) == REG_ANY) - ? RXf_ANCH_MBOL - : RXf_ANCH_SBOL; - r->extflags |= type; - r->intflags |= PREGf_IMPLICIT; + ? PREGf_ANCH_MBOL + : PREGf_ANCH_SBOL; + r->intflags |= (type | PREGf_IMPLICIT); first = NEXTOPER(first); goto again; } - if (sawplus && !sawminmod && !sawlookahead && (!sawopen || !RExC_sawback) + if (sawplus && !sawminmod && !sawlookahead + && (!sawopen || !RExC_sawback) && !pRExC_state->num_code_blocks) /* May examine pos and $& */ /* x+ must match at the 1st pos of run of x's */ r->intflags |= PREGf_SKIP; @@ -6562,9 +6850,11 @@ reStudy: } else /* XXXX Check for BOUND? */ stclass_flag = 0; data.last_closep = &last_close; - - minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */ - &data, -1, NULL, NULL, + + DEBUG_RExC_seen(); + minlen = study_chunk(pRExC_state, &first, &minlen, &fake, + scan + RExC_size, /* Up to end */ + &data, -1, 0, NULL, SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag | (restudied ? SCF_TRIE_DOING_RESTUDY : 0), 0); @@ -6576,9 +6866,11 @@ reStudy: if ( RExC_npar == 1 && data.longest == &(data.longest_fixed) && data.last_start_min == 0 && data.last_end > 0 && !RExC_seen_zerolen - && !(RExC_seen & REG_SEEN_VERBARG) - && !((RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS))) + && !(RExC_seen & REG_VERBARG_SEEN) + && !(RExC_seen & REG_GPOS_SEEN) + ){ r->extflags |= RXf_CHECK_ALL; + } scan_commit(pRExC_state, &data,&minlen,0); longest_float_length = CHR_SVLEN(data.longest_float); @@ -6659,16 +6951,19 @@ reStudy: data.start_class = NULL; } - /* A temporary algorithm prefers floated substr to fixed one to dig more info. */ + /* A temporary algorithm prefers floated substr to fixed one to dig + * more info. */ if (longest_fixed_length > longest_float_length) { + r->substrs->check_ix = 0; r->check_end_shift = r->anchored_end_shift; r->check_substr = r->anchored_substr; r->check_utf8 = r->anchored_utf8; r->check_offset_min = r->check_offset_max = r->anchored_offset; - if (r->extflags & RXf_ANCH_SINGLE) - r->extflags |= RXf_NOSCAN; + if (r->intflags & (PREGf_ANCH_SBOL|PREGf_ANCH_GPOS)) + r->intflags |= PREGf_NOSCAN; } else { + r->substrs->check_ix = 1; r->check_end_shift = r->float_end_shift; r->check_substr = r->float_substr; r->check_utf8 = r->float_utf8; @@ -6680,11 +6975,13 @@ reStudy: if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8)) r->extflags |= RXf_INTUIT_TAIL; } + r->substrs->data[0].max_offset = r->substrs->data[0].min_offset; + /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere) if ( (STRLEN)minlen < longest_float_length ) minlen= longest_float_length; if ( (STRLEN)minlen < longest_fixed_length ) - minlen= longest_fixed_length; + minlen= longest_fixed_length; */ } else { @@ -6700,13 +6997,14 @@ reStudy: data.start_class = &ch_class; data.last_closep = &last_close; - - minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size, - &data, -1, NULL, NULL, - SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS - |(restudied ? SCF_TRIE_DOING_RESTUDY : 0), + DEBUG_RExC_seen(); + minlen = study_chunk(pRExC_state, + &scan, &minlen, &fake, scan + RExC_size, &data, -1, 0, NULL, + SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied + ? SCF_TRIE_DOING_RESTUDY + : 0), 0); - + CHECK_RESTUDY_GOTO_butfirst(NOOP); r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8 @@ -6734,30 +7032,39 @@ reStudy: } } + if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) { + r->extflags |= RXf_UNBOUNDED_QUANTIFIER_SEEN; + r->maxlen = REG_INFTY; + } + else { + r->maxlen = RExC_maxlen; + } + /* Guard against an embedded (?=) or (?<=) with a longer minlen than the "real" pattern. */ DEBUG_OPTIMISE_r({ - PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n", - (IV)minlen, (IV)r->minlen); + PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf" maxlen:%ld\n", + (IV)minlen, (IV)r->minlen, RExC_maxlen); }); r->minlenret = minlen; - if (r->minlen < minlen) + if (r->minlen < minlen) r->minlen = minlen; - - if (RExC_seen & REG_SEEN_GPOS) - r->extflags |= RXf_GPOS_SEEN; - if (RExC_seen & REG_SEEN_LOOKBEHIND) - r->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the lookbehind */ + + if (RExC_seen & REG_GPOS_SEEN) + r->intflags |= PREGf_GPOS_SEEN; + if (RExC_seen & REG_LOOKBEHIND_SEEN) + r->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the + lookbehind */ if (pRExC_state->num_code_blocks) r->extflags |= RXf_EVAL_SEEN; - if (RExC_seen & REG_SEEN_CANY) - r->extflags |= RXf_CANY_SEEN; - if (RExC_seen & REG_SEEN_VERBARG) + if (RExC_seen & REG_CANY_SEEN) + r->intflags |= PREGf_CANY_SEEN; + if (RExC_seen & REG_VERBARG_SEEN) { r->intflags |= PREGf_VERBARG_SEEN; r->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */ } - if (RExC_seen & REG_SEEN_CUTGROUP) + if (RExC_seen & REG_CUTGROUP_SEEN) r->intflags |= PREGf_CUTGROUP_SEEN; if (pm_flags & PMf_USE_RE_EVAL) r->intflags |= PREGf_USE_RE_EVAL; @@ -6766,6 +7073,11 @@ reStudy: else RXp_PAREN_NAMES(r) = NULL; + /* If we have seen an anchor in our pattern then we set the extflag RXf_IS_ANCHORED + * so it can be used in pp.c */ + if (r->intflags & PREGf_ANCH) + r->extflags |= RXf_IS_ANCHORED; + { regnode *first = ri->program + 1; U8 fop = OP(first); @@ -6776,16 +7088,23 @@ reStudy: r->extflags |= RXf_NULL; else if (PL_regkind[fop] == BOL && nop == END) r->extflags |= RXf_START_ONLY; - else if (fop == PLUS && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE && OP(regnext(first)) == END) + else if (fop == PLUS + && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE + && OP(regnext(first)) == END) r->extflags |= RXf_WHITE; - else if ( r->extflags & RXf_SPLIT && fop == EXACT && STR_LEN(first) == 1 && *(STRING(first)) == ' ' && OP(regnext(first)) == END ) + else if ( r->extflags & RXf_SPLIT + && fop == EXACT + && STR_LEN(first) == 1 + && *(STRING(first)) == ' ' + && OP(regnext(first)) == END ) r->extflags |= (RXf_SKIPWHITE|RXf_WHITE); } #ifdef DEBUGGING if (RExC_paren_names) { ri->name_list_idx = add_data( pRExC_state, STR_WITH_LEN("a")); - ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list); + ri->data->data[ri->name_list_idx] + = (void*)SvREFCNT_inc(RExC_paren_name_list); } else #endif ri->name_list_idx = 0; @@ -6800,6 +7119,7 @@ reStudy: /* assume we don't need to swap parens around before we match */ DEBUG_DUMP_r({ + DEBUG_RExC_seen(); PerlIO_printf(Perl_debug_log,"Final program:\n"); regdump(r); }); @@ -6808,7 +7128,8 @@ reStudy: const STRLEN len = ri->u.offsets[0]; STRLEN i; GET_RE_DEBUG_FLAGS_DECL; - PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]); + PerlIO_printf(Perl_debug_log, + "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]); for (i = 1; i <= len; i++) { if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2]) PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ", @@ -6868,7 +7189,8 @@ Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey, 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); + Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", + (int)flags); return NULL; } } @@ -7009,7 +7331,8 @@ Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags) SvREFCNT_dec_NN(ret); return newSViv(length + 1); } else { - Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags); + Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", + (int)flags); return NULL; } } @@ -7062,7 +7385,7 @@ Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren, 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 @@ -7095,14 +7418,14 @@ Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren, i = rx->offs[0].start; s = rx->subbeg; } - else + 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 ( 0 <= n && n <= (I32)rx->nparens && (s1 = rx->offs[n].start) != -1 && @@ -7113,12 +7436,12 @@ Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren, 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) { -#if NO_TAINT_SUPPORT +#ifdef NO_TAINT_SUPPORT sv_setpvn(sv, s, i); #else const int oldtainted = TAINT_get; @@ -7126,7 +7449,7 @@ Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren, sv_setpvn(sv, s, i); TAINT_set(oldtainted); #endif - if ( (rx->extflags & RXf_CANY_SEEN) + if ( (rx->intflags & PREGf_CANY_SEEN) ? (RXp_MATCH_UTF8(rx) && (!i || is_utf8_string((U8*)s, i))) : (RXp_MATCH_UTF8(rx)) ) @@ -7151,7 +7474,7 @@ Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren, TAINT; SvTAINT(sv); } - } else + } else SvTAINTED_off(sv); } } else { @@ -7299,7 +7622,8 @@ S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags) RExC_parse++; } while (isWORDCHAR(*RExC_parse)); } else { - RExC_parse++; /* so the <- from the vFAIL is after the offending character */ + RExC_parse++; /* so the <- from the vFAIL is after the offending + character */ vFAIL("Group name must start with a non-digit word character"); } if ( flags ) { @@ -7566,10 +7890,9 @@ Perl__new_invlist(pTHX_ IV initial_size) return new_list; } -#endif -STATIC SV* -S__new_invlist_C_array(pTHX_ const UV* const 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 , which has to be in the exact correct inversion list @@ -7619,8 +7942,11 @@ S__new_invlist_C_array(pTHX_ const UV* const list) /* Initialize the iteration pointer. */ invlist_iterfinish(invlist); + SvREADONLY_on(invlist); + return invlist; } +#endif /* ifndef PERL_IN_XSUB_RE */ STATIC void S_invlist_extend(pTHX_ SV* const invlist, const UV new_max) @@ -7649,7 +7975,8 @@ S_invlist_trim(pTHX_ SV* const invlist) } STATIC void -S__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end) +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 @@ -7679,8 +8006,8 @@ S__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end || 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'); + array[final_element], start, + ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f'); } /* Here, it is a legal append. If the new range begins with the first @@ -7823,7 +8150,8 @@ Perl__invlist_search(pTHX_ SV* const invlist, const UV cp) } void -Perl__invlist_populate_swatch(pTHX_ SV* const invlist, const UV start, const UV end, U8* swatch) +Perl__invlist_populate_swatch(pTHX_ SV* const invlist, + const UV start, const UV end, U8* swatch) { /* populates a swatch of a swash the same way swatch_get() does in utf8.c, * but is used when the swash has an inversion list. This makes this much @@ -7916,7 +8244,8 @@ Perl__invlist_populate_swatch(pTHX_ SV* const invlist, const UV start, const UV } void -Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, const bool complement_b, SV** output) +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 to it. *output * SHOULD BE DEFINED upon input, and if it points to one of the two lists, @@ -8171,7 +8500,8 @@ Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, const b } void -Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, const bool complement_b, SV** i) +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 to it. *i * SHOULD BE DEFINED upon input, and if it points to one of the two lists, @@ -8364,7 +8694,8 @@ Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, } /* The final length is what we've output so far plus what else is in the - * intersection. At most one of the subexpressions below will be non-zero */ + * intersection. At most one of the subexpressions below will be non-zero + * */ len_r = i_r; if (count >= 2) { len_r += (len_a - i_a) + (len_b - i_b); @@ -8450,6 +8781,35 @@ Perl__add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end) 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; + + _append_range_to_invlist(invlist, element0, element0); + offset = *get_invlist_offset_addr(invlist); + + invlist_set_len(invlist, size, offset); + *other_elements_ptr = invlist_array(invlist) + 1; + return invlist; +} + #endif PERL_STATIC_INLINE SV* @@ -8478,43 +8838,6 @@ Perl__invlist_invert(pTHX_ SV* const invlist) *get_invlist_offset_addr(invlist) = ! *get_invlist_offset_addr(invlist); } -void -Perl__invlist_invert_prop(pTHX_ SV* const invlist) -{ - /* Complement the input inversion list (which must be a Unicode property, - * all of which don't match above the Unicode maximum code point.) And - * Perl has chosen to not have the inversion match above that either. This - * adds a 0x110000 if the list didn't end with it, and removes it if it did - */ - - UV len; - UV* array; - - PERL_ARGS_ASSERT__INVLIST_INVERT_PROP; - - _invlist_invert(invlist); - - len = _invlist_len(invlist); - - if (len != 0) { /* If empty do nothing */ - array = invlist_array(invlist); - if (array[len - 1] != PERL_UNICODE_MAX + 1) { - /* Add 0x110000. First, grow if necessary */ - len++; - if (invlist_max(invlist) < len) { - invlist_extend(invlist, len); - array = invlist_array(invlist); - } - invlist_set_len(invlist, len, *get_invlist_offset_addr(invlist)); - array[len - 1] = PERL_UNICODE_MAX + 1; - } - else { /* Remove the 0x110000 */ - invlist_set_len(invlist, len - 1, *get_invlist_offset_addr(invlist)); - } - } - - return; -} #endif PERL_STATIC_INLINE SV* @@ -8684,7 +9007,8 @@ Perl__invlist_contents(pTHX_ SV* const invlist) #ifndef PERL_IN_XSUB_RE void -Perl__invlist_dump(pTHX_ PerlIO *file, I32 level, const char * const indent, SV* const invlist) +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 @@ -8917,7 +9241,8 @@ S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state) vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD); } else if (has_charset_modifier == *(RExC_parse - 1)) { - vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1)); + vFAIL2("Regexp modifier \"%c\" may not appear twice", + *(RExC_parse - 1)); } else { vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1)); @@ -8925,12 +9250,15 @@ S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state) /*NOTREACHED*/ neg_modifier: RExC_parse++; - vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1)); + vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", + *(RExC_parse - 1)); /*NOTREACHED*/ case ONCE_PAT_MOD: /* 'o' */ case GLOBAL_PAT_MOD: /* 'g' */ if (SIZE_ONLY && ckWARN(WARN_REGEXP)) { - const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G; + const I32 wflagbit = *RExC_parse == 'o' + ? WASTED_O + : WASTED_G; if (! (wastedflags & wflagbit) ) { wastedflags |= wflagbit; /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */ @@ -9068,7 +9396,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) char *start_arg = NULL; unsigned char op = 0; int argok = 1; - int internal_argval = 0; /* internal_argval is only useful if !argok */ + int internal_argval = 0; /* internal_argval is only useful if + !argok */ if (has_intervening_patws && SIZE_ONLY) { ckWARNregdep(RExC_parse + 1, "In '(*VERB...)', splitting the initial '(*' is deprecated"); @@ -9084,9 +9413,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) verb_len = RExC_parse - start_verb; if ( start_arg ) { RExC_parse++; - while ( *RExC_parse && *RExC_parse != ')' ) + while ( *RExC_parse && *RExC_parse != ')' ) RExC_parse++; - if ( *RExC_parse != ')' ) + if ( *RExC_parse != ')' ) vFAIL("Unterminated verb pattern argument"); if ( RExC_parse == start_arg ) start_arg = NULL; @@ -9094,7 +9423,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) if ( *RExC_parse != ')' ) vFAIL("Unterminated verb pattern"); } - + switch ( *start_verb ) { case 'A': /* (*ACCEPT) */ if ( memEQs(start_verb,verb_len,"ACCEPT") ) { @@ -9123,15 +9452,15 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) if ( memEQs(start_verb,verb_len,"PRUNE") ) op = PRUNE; break; - case 'S': /* (*SKIP) */ - if ( memEQs(start_verb,verb_len,"SKIP") ) + case 'S': /* (*SKIP) */ + if ( memEQs(start_verb,verb_len,"SKIP") ) op = SKIP; break; case 'T': /* (*THEN) */ /* [19:06] :: is then */ if ( memEQs(start_verb,verb_len,"THEN") ) { op = CUTGROUP; - RExC_seen |= REG_SEEN_CUTGROUP; + RExC_seen |= REG_CUTGROUP_SEEN; } break; } @@ -9144,28 +9473,30 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) if ( argok ) { if ( start_arg && internal_argval ) { vFAIL3("Verb pattern '%.*s' may not have an argument", - verb_len, start_verb); + verb_len, start_verb); } else if ( argok < 0 && !start_arg ) { vFAIL3("Verb pattern '%.*s' has a mandatory argument", - verb_len, start_verb); + verb_len, start_verb); } else { ret = reganode(pRExC_state, op, internal_argval); if ( ! internal_argval && ! SIZE_ONLY ) { if (start_arg) { - SV *sv = newSVpvn( start_arg, RExC_parse - start_arg); - ARG(ret) = add_data( pRExC_state, STR_WITH_LEN("S")); + SV *sv = newSVpvn( start_arg, + RExC_parse - start_arg); + ARG(ret) = add_data( pRExC_state, + STR_WITH_LEN("S")); RExC_rxi->data->data[ARG(ret)]=(void*)sv; ret->flags = 0; } else { - ret->flags = 1; + ret->flags = 1; } - } + } } if (!internal_argval) - RExC_seen |= REG_SEEN_VERBARG; + RExC_seen |= REG_VERBARG_SEEN; } else if ( start_arg ) { vFAIL3("Verb pattern '%.*s' may not have an argument", - verb_len, start_verb); + verb_len, start_verb); } else { ret = reg_node(pRExC_state, op); } @@ -9192,8 +9523,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) goto named_recursion; } else if (paren == '=') { /* (?P=...) named backref */ - /* this pretty much dupes the code for \k in regatom(), if - you change this make sure you change that */ + /* this pretty much dupes the code for \k in + * regatom(), if you change this make sure you change that + * */ char* name_start = RExC_parse; U32 num = 0; SV *sv_dat = reg_scan_name(pRExC_state, @@ -9229,12 +9561,13 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) } RExC_parse++; /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */ - vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart); + vFAIL3("Sequence (%.*s...) not recognized", + RExC_parse-seqstart, seqstart); /*NOTREACHED*/ case '<': /* (?<...) */ if (*RExC_parse == '!') paren = ','; - else if (*RExC_parse != '=') + else if (*RExC_parse != '=') named_capture: { /* (?<...>) */ char *name_start; @@ -9243,9 +9576,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) case '\'': /* (?'...') */ name_start= RExC_parse; svname = reg_scan_name(pRExC_state, - SIZE_ONLY ? /* reverse test from the others */ - REG_RSN_RETURN_NAME : - REG_RSN_RETURN_NULL); + SIZE_ONLY /* reverse test from the others */ + ? REG_RSN_RETURN_NAME + : REG_RSN_RETURN_NULL); if (RExC_parse == name_start || *RExC_parse != paren) vFAIL2("Sequence (?%c... not terminated", paren=='>' ? '<' : paren); @@ -9286,20 +9619,24 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) } } if ( count ) { - pv = (I32*)SvGROW(sv_dat, SvCUR(sv_dat) + sizeof(I32)+1); + pv = (I32*)SvGROW(sv_dat, + SvCUR(sv_dat) + sizeof(I32)+1); SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32)); pv[count] = RExC_npar; SvIV_set(sv_dat, SvIVX(sv_dat) + 1); } } else { (void)SvUPGRADE(sv_dat,SVt_PVNV); - sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32)); + sv_setpvn(sv_dat, (char *)&(RExC_npar), + sizeof(I32)); SvIOK_on(sv_dat); SvIV_set(sv_dat, 1); } #ifdef DEBUGGING - /* Yes this does cause a memory leak in debugging Perls */ - if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname))) + /* Yes this does cause a memory leak in debugging Perls + * */ + if (!av_store(RExC_paren_name_list, + RExC_npar, SvREFCNT_inc(svname))) SvREFCNT_dec_NN(svname); #endif @@ -9309,7 +9646,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) paren = 1; goto capturing_parens; } - RExC_seen |= REG_SEEN_LOOKBEHIND; + RExC_seen |= REG_LOOKBEHIND_SEEN; RExC_in_lookbehind++; RExC_parse++; case '=': /* (?=...) */ @@ -9326,7 +9663,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) case '|': /* (?|...) */ /* branch reset, behave like a (?:...) except that buffers in alternations share the same numbers */ - paren = ':'; + paren = ':'; after_freeze = freeze_paren = RExC_npar; break; case ':': /* (?:...) */ @@ -9353,6 +9690,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) if (*RExC_parse != ')') FAIL("Sequence (?R) not terminated"); ret = reg_node(pRExC_state, GOSTART); + RExC_seen |= REG_GOSTART_SEEN; *flagp |= POSTPONED; nextchar(pRExC_state); return ret; @@ -9382,7 +9720,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) { RExC_parse--; /* rewind to let it be handled later */ goto parse_flags; - } + } /*FALLTHROUGH */ case '1': case '2': case '3': case '4': /* (?1) */ case '5': case '6': case '7': case '8': case '9': @@ -9394,7 +9732,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) RExC_parse++; while (isDIGIT(*RExC_parse)) RExC_parse++; - if (*RExC_parse!=')') + if (*RExC_parse!=')') vFAIL("Expecting close bracket"); gen_recurse_regop: @@ -9428,11 +9766,12 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) ARG2L_SET( ret, RExC_recurse_count++); RExC_emit++; DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log, - "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret))); + "Recurse #%"UVuf" to %"IVdf"\n", + (UV)ARG(ret), (IV)ARG2L(ret))); } else { RExC_size++; } - RExC_seen |= REG_SEEN_RECURSE; + RExC_seen |= REG_RECURSE_SEEN; Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */ Set_Node_Offset(ret, parse_start); /* MJD */ @@ -9523,7 +9862,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) ret = reg_node(pRExC_state, LOGICAL); if (!SIZE_ONLY) ret->flags = 1; - + tail = reg(pRExC_state, 1, &flag, depth+1); if (flag & RESTART_UTF8) { *flagp = RESTART_UTF8; @@ -9576,10 +9915,12 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) SV *sv_dat; RExC_parse++; sv_dat = reg_scan_name(pRExC_state, - SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA); + SIZE_ONLY + ? REG_RSN_RETURN_NULL + : REG_RSN_RETURN_DATA); parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0; } - ret = reganode(pRExC_state,INSUBP,parno); + ret = reganode(pRExC_state,INSUBP,parno); goto insert_if_check_paren; } else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) { @@ -9612,14 +9953,18 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"", (UV) flags); } else - REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0)); + REGTAIL(pRExC_state, br, reganode(pRExC_state, + LONGJMP, 0)); c = *nextchar(pRExC_state); if (flags&HASWIDTH) *flagp |= HASWIDTH; if (c == '|') { - if (is_define) + if (is_define) vFAIL("(?(DEFINE)....) does not allow branches"); - lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */ + + /* Fake one for optimizer. */ + lastbr = reganode(pRExC_state, IFTHEN, 0); + if (!regbranch(pRExC_state, &flags, 1,depth+1)) { if (flags & RESTART_UTF8) { *flagp = RESTART_UTF8; @@ -9681,16 +10026,16 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) capturing_parens: parno = RExC_npar; RExC_npar++; - + ret = reganode(pRExC_state, OPEN, parno); if (!SIZE_ONLY ){ - if (!RExC_nestroot) + if (!RExC_nestroot) RExC_nestroot = parno; - if (RExC_seen & REG_SEEN_RECURSE + if (RExC_seen & REG_RECURSE_SEEN && !RExC_open_parens[parno-1]) { DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log, - "Setting open paren #%"IVdf" to %d\n", + "Setting open paren #%"IVdf" to %d\n", (IV)parno, REG_NODE_NUM(ret))); RExC_open_parens[parno-1]= ret; } @@ -9702,7 +10047,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) } else /* ! paren */ ret = NULL; - + parse_rest: /* Pick up the branches, linking them together. */ parse_start = RExC_parse; /* MJD */ @@ -9743,7 +10088,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) while (*RExC_parse == '|') { if (!SIZE_ONLY && RExC_extralen) { ender = reganode(pRExC_state, LONGJMP,0); - REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */ + + /* Append to the previous. */ + REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); } if (SIZE_ONLY) RExC_extralen += 2; /* Account for LONGJMP. */ @@ -9751,7 +10098,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) if (freeze_paren) { if (RExC_npar > after_freeze) after_freeze = RExC_npar; - RExC_npar = freeze_paren; + RExC_npar = freeze_paren; } br = regbranch(pRExC_state, &flags, 0, depth+1); @@ -9775,14 +10122,14 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) break; case 1: case 2: ender = reganode(pRExC_state, CLOSE, parno); - if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) { + if (!SIZE_ONLY && RExC_seen & REG_RECURSE_SEEN) { DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log, - "Setting close paren #%"IVdf" to %d\n", + "Setting close paren #%"IVdf" to %d\n", (IV)parno, REG_NODE_NUM(ender))); RExC_close_parens[parno-1]= ender; - if (RExC_nestroot == parno) + if (RExC_nestroot == parno) RExC_nestroot = 0; - } + } Set_Node_Offset(ender,RExC_parse+1); /* MJD */ Set_Node_Length(ender,1); /* MJD */ break; @@ -9822,20 +10169,22 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) if (have_branch && !SIZE_ONLY) { char is_nothing= 1; if (depth==1) - RExC_seen |= REG_TOP_LEVEL_BRANCHES; + RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN; /* Hook the tails of the branches to the closing node. */ for (br = ret; br; br = regnext(br)) { const U8 op = PL_regkind[OP(br)]; if (op == BRANCH) { REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender); - if (OP(NEXTOPER(br)) != NOTHING || regnext(NEXTOPER(br)) != ender) + if ( OP(NEXTOPER(br)) != NOTHING + || regnext(NEXTOPER(br)) != ender) is_nothing= 0; } else if (op == BRANCHJ) { REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender); /* for now we always disable this optimisation * / - if (OP(NEXTOPER(NEXTOPER(br))) != NOTHING || regnext(NEXTOPER(NEXTOPER(br))) != ender) + if ( OP(NEXTOPER(NEXTOPER(br))) != NOTHING + || regnext(NEXTOPER(NEXTOPER(br))) != ender) */ is_nothing= 0; } @@ -10089,6 +10438,19 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) ret = reg_node(pRExC_state, OPFAIL); return ret; } + else if (min == max + && RExC_parse < RExC_end + && (*RExC_parse == '?' || *RExC_parse == '+')) + { + if (SIZE_ONLY) { + ckWARN2reg(RExC_parse + 1, + "Useless use of greediness modifier '%c'", + *RExC_parse); + } + /* Absorb the modifier, so later code doesn't see nor use + * it */ + nextchar(pRExC_state); + } do_curly: if ((flags&SIMPLE)) { @@ -10130,6 +10492,8 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) ARG1_SET(ret, (U16)min); ARG2_SET(ret, (U16)max); } + if (max == REG_INFTY) + RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN; goto nest_check; } @@ -10167,6 +10531,7 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) reginsert(pRExC_state, STAR, ret, depth+1); ret->flags = 0; RExC_naughty += 4; + RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN; } else if (op == '*') { min = 0; @@ -10176,6 +10541,7 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) reginsert(pRExC_state, PLUS, ret, depth+1); ret->flags = 0; RExC_naughty += 3; + RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN; } else if (op == '+') { min = 1; @@ -10190,7 +10556,9 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */ ckWARN2reg(RExC_parse, "%"UTF8f" matches null string many times", - UTF8fARG(UTF, (RExC_parse >= origparse ? RExC_parse - origparse : 0), + UTF8fARG(UTF, (RExC_parse >= origparse + ? RExC_parse - origparse + : 0), origparse)); (void)ReREFCNT_inc(RExC_rx_sv); } @@ -10221,11 +10589,12 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) } STATIC bool -S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, UV *valuep, I32 *flagp, U32 depth, bool in_char_class, - const bool strict /* Apply stricter parsing rules? */ +S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, + UV *valuep, I32 *flagp, U32 depth, bool in_char_class, + const bool strict /* Apply stricter parsing rules? */ ) { - + /* This is expected to be called by a parser routine that has recognized '\N' and needs to handle the rest. RExC_parse is expected to point at the first char following the N at the time of the call. On successful return, @@ -10280,7 +10649,7 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, UV *valuep, I more than one character */ GET_RE_DEBUG_FLAGS_DECL; - + PERL_ARGS_ASSERT_GROK_BSLASH_N; GET_RE_DEBUG_FLAGS; @@ -10329,8 +10698,10 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, UV *valuep, I if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */ || ! (endbrace == RExC_parse /* nothing between the {} */ - || (endbrace - RExC_parse >= 2 /* U+ (bad hex is checked below */ - && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) */ + || (endbrace - RExC_parse >= 2 /* U+ (bad hex is checked below + */ + && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) + */ { if (endbrace) RExC_parse = endbrace; /* position msg's '<--HERE' */ vFAIL("\\N{NAME} must be resolved by the lexer"); @@ -10468,7 +10839,7 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, UV *valuep, I } FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#"UVxf"", (UV) flags); - } + } *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED); RExC_parse = endbrace; @@ -10536,7 +10907,8 @@ S_compute_EXACTish(pTHX_ RExC_state_t *pRExC_state) } PERL_STATIC_INLINE void -S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state, regnode *node, I32* flagp, STRLEN len, UV code_point) +S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state, + regnode *node, I32* flagp, STRLEN len, UV code_point) { /* This knows the details about sizing an EXACTish node, setting flags for * it (by setting <*flagp>, and potentially populating it with a single @@ -10551,8 +10923,10 @@ S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state, regnode *node, I32 * If is zero, the function assumes that the node is to contain only * the single character given by and calculates what * should be. In pass 1, it sizes the node appropriately. In pass 2, it - * additionally will populate the node's STRING with , if - * is 0. In both cases <*flagp> is appropriately set + * additionally will populate the node's STRING with or its + * fold if folding. + * + * In both cases <*flagp> is appropriately set * * It knows that under FOLD, the Latin Sharp S and UTF characters above * 255, must be folded (the former only when the rules indicate it can @@ -10565,34 +10939,54 @@ S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state, regnode *node, I32 if (! len_passed_in) { if (UTF) { - if (FOLD && (! LOC || code_point > 255)) { + if (UNI_IS_INVARIANT(code_point)) { + if (LOC || ! FOLD) { /* /l defers folding until runtime */ + *character = (U8) code_point; + } + else { /* Here is /i and not /l (toFOLD() is defined on just + ASCII, which isn't the same thing as INVARIANT on + EBCDIC, but it works there, as the extra invariants + fold to themselves) */ + *character = toFOLD((U8) code_point); + } + len = 1; + } + else if (FOLD && (! LOC + || ! is_PROBLEMATIC_LOCALE_FOLD_cp(code_point))) + { /* Folding, and ok to do so now */ _to_uni_fold_flags(code_point, character, &len, - FOLD_FLAGS_FULL | ((LOC) - ? FOLD_FLAGS_LOCALE - : (ASCII_FOLD_RESTRICTED) - ? FOLD_FLAGS_NOMIX_ASCII - : 0)); + FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED) + ? FOLD_FLAGS_NOMIX_ASCII + : 0)); + } + else if (code_point <= MAX_UTF8_TWO_BYTE) { + + /* Not folding this cp, and can output it directly */ + *character = UTF8_TWO_BYTE_HI(code_point); + *(character + 1) = UTF8_TWO_BYTE_LO(code_point); + len = 2; } else { uvchr_to_utf8( character, code_point); len = UTF8SKIP(character); } - } - else if (! FOLD - || code_point != LATIN_SMALL_LETTER_SHARP_S - || ASCII_FOLD_RESTRICTED - || ! AT_LEAST_UNI_SEMANTICS) + } /* Else pattern isn't UTF8. We only fold the sharp s, when + appropriate */ + else if (UNLIKELY(code_point == LATIN_SMALL_LETTER_SHARP_S) + && FOLD + && AT_LEAST_UNI_SEMANTICS + && ! ASCII_FOLD_RESTRICTED) { - *character = (U8) code_point; - len = 1; - } - else { *character = 's'; *(character + 1) = 's'; len = 2; } + else { + *character = (U8) code_point; + len = 1; + } } if (SIZE_ONLY) { @@ -10694,7 +11088,7 @@ S_backref_value(char *p) by the other. Returns NULL, setting *flagp to TRYAGAIN if reg() returns NULL with - TRYAGAIN. + TRYAGAIN. Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be restarted. Otherwise does not return NULL. @@ -10791,7 +11185,8 @@ tryagain: *flagp = RESTART_UTF8; return NULL; } - FAIL2("panic: reg returned NULL to regatom, flags=%#"UVxf"", (UV) flags); + FAIL2("panic: reg returned NULL to regatom, flags=%#"UVxf"", + (UV) flags); } *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED); break; @@ -10839,7 +11234,7 @@ tryagain: goto finish_meta_pat; case 'G': ret = reg_node(pRExC_state, GPOS); - RExC_seen |= REG_SEEN_GPOS; + RExC_seen |= REG_GPOS_SEEN; *flagp |= SIMPLE; goto finish_meta_pat; case 'K': @@ -10850,7 +11245,7 @@ tryagain: * be necessary here to avoid cases of memory corruption, as * with: C<$_="x" x 80; s/x\K/y/> -- rgs */ - RExC_seen |= REG_SEEN_LOOKBEHIND; + RExC_seen |= REG_LOOKBEHIND_SEEN; goto finish_meta_pat; case 'Z': ret = reg_node(pRExC_state, SEOL); @@ -10864,7 +11259,7 @@ tryagain: goto finish_meta_pat; case 'C': ret = reg_node(pRExC_state, CANY); - RExC_seen |= REG_SEEN_CANY; + RExC_seen |= REG_CANY_SEEN; *flagp |= HASWIDTH|SIMPLE; goto finish_meta_pat; case 'X': @@ -10881,7 +11276,7 @@ tryagain: case 'b': RExC_seen_zerolen++; - RExC_seen |= REG_SEEN_LOOKBEHIND; + RExC_seen |= REG_LOOKBEHIND_SEEN; op = BOUND + get_regex_charset(RExC_flags); if (op > BOUNDA) { /* /aa is same as /a */ op = BOUNDA; @@ -10890,12 +11285,13 @@ tryagain: FLAGS(ret) = get_regex_charset(RExC_flags); *flagp |= SIMPLE; if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') { - ckWARNdep(RExC_parse, "\"\\b{\" is deprecated; use \"\\b\\{\" or \"\\b[{]\" instead"); + /* diag_listed_as: Use "%s" instead of "%s" */ + vFAIL("Use \"\\b\\{\" instead of \"\\b{\""); } goto finish_meta_pat; case 'B': RExC_seen_zerolen++; - RExC_seen |= REG_SEEN_LOOKBEHIND; + RExC_seen |= REG_LOOKBEHIND_SEEN; op = NBOUND + get_regex_charset(RExC_flags); if (op > NBOUNDA) { /* /aa is same as /a */ op = NBOUNDA; @@ -10904,7 +11300,8 @@ tryagain: FLAGS(ret) = get_regex_charset(RExC_flags); *flagp |= SIMPLE; if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') { - ckWARNdep(RExC_parse, "\"\\B{\" is deprecated; use \"\\B\\{\" or \"\\B[{]\" instead"); + /* diag_listed_as: Use "%s" instead of "%s" */ + vFAIL("Use \"\\B\\{\" instead of \"\\B{\""); } goto finish_meta_pat; @@ -10963,10 +11360,10 @@ tryagain: *flagp |= HASWIDTH|SIMPLE; /* FALL THROUGH */ - finish_meta_pat: + finish_meta_pat: nextchar(pRExC_state); Set_Node_Length(ret, 2); /* MJD */ - break; + break; case 'p': case 'P': { @@ -10996,7 +11393,7 @@ tryagain: nextchar(pRExC_state); } break; - case 'N': + case 'N': /* Handle \N and \N{NAME} with multiple code points here and not * below because it can be multicharacter. join_exact() will join * them up later on. Also this makes sure that things like @@ -11018,8 +11415,8 @@ tryagain: break; case 'k': /* Handle \k and \k'NAME' */ parse_named_seq: - { - char ch= RExC_parse[1]; + { + char ch= RExC_parse[1]; if (ch != '<' && ch != '\'' && ch != '{') { RExC_parse++; /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */ @@ -11064,7 +11461,7 @@ tryagain: } break; } - case 'g': + case 'g': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': { @@ -11085,7 +11482,7 @@ tryagain: } if (hasbrace && !isDIGIT(*RExC_parse)) { if (isrel) RExC_parse--; - RExC_parse -= 2; + RExC_parse -= 2; goto parse_named_seq; } @@ -11123,10 +11520,10 @@ tryagain: while (isDIGIT(*RExC_parse)) RExC_parse++; if (hasbrace) { - if (*RExC_parse != '}') + if (*RExC_parse != '}') vFAIL("Unterminated \\g{...} pattern"); RExC_parse++; - } + } if (!SIZE_ONLY) { if (num > (I32)RExC_rx->nparens) vFAIL("Reference to nonexistent group"); @@ -11187,7 +11584,6 @@ tryagain: char foldbuf[MAX_NODE_STRING_SIZE+UTF8_MAXBYTES_CASE]; char *s0; U8 upper_parse = MAX_NODE_STRING_SIZE; - STRLEN foldlen; U8 node_type = compute_EXACTish(pRExC_state); bool next_is_quantifier; char * oldp = NULL; @@ -11195,9 +11591,15 @@ tryagain: /* We can convert EXACTF nodes to EXACTFU if they contain only * characters that match identically regardless of the target * string's UTF8ness. The reason to do this is that EXACTF is not - * trie-able, EXACTFU is. (We don't need to figure this out until - * pass 2) */ - bool maybe_exactfu = node_type == EXACTF && PASS2; + * trie-able, EXACTFU is. + * + * Similarly, we can convert EXACTFL nodes to EXACTFU if they + * contain only above-Latin1 characters (hence must be in UTF8), + * which don't participate in folds with Latin1-range characters, + * as the latter's folds aren't known until runtime. (We don't + * need to figure this out until pass 2) */ + bool maybe_exactfu = PASS2 + && (node_type == EXACTF || node_type == EXACTFL); /* If a folding node contains only code points that don't * participate in folds, it can be changed into an EXACT node, @@ -11214,10 +11616,9 @@ tryagain: reparse: - /* We do the EXACTFish to EXACT node only if folding, and not if in - * locale, as whether a character folds or not isn't known until - * runtime. (And we don't need to figure this out until pass 2) */ - maybe_exact = FOLD && ! LOC && PASS2; + /* We do the EXACTFish to EXACT node only if folding. (And we + * don't need to figure this out until pass 2) */ + maybe_exact = FOLD && PASS2; /* XXX The node can hold up to 255 bytes, yet this only goes to * 127. I (khw) do not know why. Keeping it somewhat less than @@ -11282,7 +11683,8 @@ tryagain: case 's': case 'S': /* space class */ case 'v': case 'V': /* VERTWS */ case 'w': case 'W': /* word class */ - case 'X': /* eXtended Unicode "combining character sequence" */ + case 'X': /* eXtended Unicode "combining + character sequence" */ case 'z': case 'Z': /* End of line/string assertion */ --p; goto loopdone; @@ -11393,7 +11795,7 @@ tryagain: } case 'c': p++; - ender = grok_bslash_c(*p++, UTF, SIZE_ONLY); + ender = grok_bslash_c(*p++, SIZE_ONLY); break; case '8': case '9': /* must be a backreference */ --p; @@ -11507,7 +11909,10 @@ tryagain: goto loopdone; } - if (! FOLD) { + if (! FOLD /* The simple case, just append the literal */ + || (LOC /* Also don't fold for tricky chars under /l */ + && is_PROBLEMATIC_LOCALE_FOLD_cp(ender))) + { if (UTF) { const STRLEN unilen = reguni(pRExC_state, ender, s); if (unilen > 0) { @@ -11525,13 +11930,27 @@ tryagain: else { REGC((char)ender, s++); } + + /* Can get here if folding only if is one of the /l + * characters whose fold depends on the locale. The + * occurrence of any of these indicate that we can't + * simplify things */ + if (FOLD) { + maybe_exact = FALSE; + maybe_exactfu = FALSE; + } } - else /* FOLD */ if (! ( UTF + else /* FOLD */ + if (! ( UTF /* See comments for join_exact() as to why we fold this * non-UTF at compile time */ || (node_type == EXACTFU && ender == LATIN_SMALL_LETTER_SHARP_S))) { + /* Here, are folding and are not UTF-8 encoded; therefore + * the character must be in the range 0-255, and is not /l + * (Not /l because we already handled these under /l in + * is_PROBLEMATIC_LOCALE_FOLD_cp */ if (IS_IN_SOME_FOLD_L1(ender)) { maybe_exact = FALSE; @@ -11543,77 +11962,68 @@ tryagain: || ender == LATIN_SMALL_LETTER_SHARP_S || (len > 0 && isARG2_lower_or_UPPER_ARG1('s', ender) - && isARG2_lower_or_UPPER_ARG1('s', *(s-1))))) + && isARG2_lower_or_UPPER_ARG1('s', + *(s-1))))) { maybe_exactfu = FALSE; } } + + /* Even when folding, we store just the input character, as + * we have an array that finds its fold quickly */ *(s++) = (char) ender; } - else { /* UTF */ - - /* Prime the casefolded buffer. Locale rules, which apply - * only to code points < 256, aren't known until execution, - * so for them, just output the original character using - * utf8. If we start to fold non-UTF patterns, be sure to - * update join_exact() */ - if (LOC && ender < 256) { - if (UVCHR_IS_INVARIANT(ender)) { - *s = (U8) ender; - foldlen = 1; - } else { - *s = UTF8_TWO_BYTE_HI(ender); - *(s + 1) = UTF8_TWO_BYTE_LO(ender); - foldlen = 2; - } + else { /* FOLD and UTF */ + /* Unlike the non-fold case, we do actually have to + * calculate the results here in pass 1. This is for two + * reasons, the folded length may be longer than the + * unfolded, and we have to calculate how many EXACTish + * nodes it will take; and we may run out of room in a node + * in the middle of a potential multi-char fold, and have + * to back off accordingly. (Hence we can't use REGC for + * the simple case just below.) */ + + UV folded; + if (isASCII(ender)) { + folded = toFOLD(ender); + *(s)++ = (U8) folded; } else { - UV folded = _to_uni_fold_flags( - ender, - (U8 *) s, - &foldlen, - FOLD_FLAGS_FULL - | ((LOC) ? FOLD_FLAGS_LOCALE - : (ASCII_FOLD_RESTRICTED) - ? FOLD_FLAGS_NOMIX_ASCII - : 0) - ); - - /* If this node only contains non-folding code points - * so far, see if this new one is also non-folding */ - if (maybe_exact) { - if (folded != ender) { + STRLEN foldlen; + + folded = _to_uni_fold_flags( + ender, + (U8 *) s, + &foldlen, + FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED) + ? FOLD_FLAGS_NOMIX_ASCII + : 0)); + s += foldlen; + + /* The loop increments each time, as all but this + * path (and one other) through it add a single byte to + * the EXACTish node. But this one has changed len to + * be the correct final value, so subtract one to + * cancel out the increment that follows */ + len += foldlen - 1; + } + /* If this node only contains non-folding code points so + * far, see if this new one is also non-folding */ + if (maybe_exact) { + if (folded != ender) { + maybe_exact = FALSE; + } + else { + /* Here the fold is the original; we have to check + * further to see if anything folds to it */ + if (_invlist_contains_cp(PL_utf8_foldable, + ender)) + { maybe_exact = FALSE; } - else { - /* Here the fold is the original; we have - * to check further to see if anything - * folds to it */ - if (! PL_utf8_foldable) { - SV* swash = swash_init("utf8", - "_Perl_Any_Folds", - &PL_sv_undef, 1, 0); - PL_utf8_foldable = - _get_swash_invlist(swash); - SvREFCNT_dec_NN(swash); - } - if (_invlist_contains_cp(PL_utf8_foldable, - ender)) - { - maybe_exact = FALSE; - } - } } - ender = folded; } - s += foldlen; - - /* The loop increments each time, as all but this - * path (and one other) through it add a single byte to the - * EXACTish node. But this one has changed len to be the - * correct final value, so subtract one to cancel out the - * increment that follows */ - len += foldlen - 1; + ender = folded; } if (next_is_quantifier) { @@ -11662,9 +12072,8 @@ tryagain: if (! UTF) { - /* These two have no multi-char folds to non-UTF characters - */ - if (ASCII_FOLD_RESTRICTED || LOC) { + /* This has no multi-char folds to non-UTF characters */ + if (ASCII_FOLD_RESTRICTED) { goto loopdone; } @@ -11695,11 +12104,7 @@ tryagain: } } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) { - - /* No Latin1 characters participate in multi-char - * folds under /l */ - if (LOC - || ! IS_NON_FINAL_FOLD(TWO_BYTE_UTF8_TO_NATIVE( + if (! IS_NON_FINAL_FOLD(TWO_BYTE_UTF8_TO_NATIVE( *s, *(s+1)))) { break; @@ -11810,7 +12215,7 @@ tryagain: * code points in the node that participate in folds; * similarly for 'maybe_exactfu' and code points that match * differently depending on UTF8ness of the target string - * */ + * (for /u), or depending on locale for /l */ if (maybe_exact) { OP(ret) = EXACT; } @@ -11857,7 +12262,7 @@ S_regwhite( RExC_state_t *pRExC_state, char *p ) } } while (p < e); if (!ended) - RExC_seen |= REG_SEEN_RUN_ON_COMMENT; + RExC_seen |= REG_RUN_ON_COMMENT_SEEN; } else break; @@ -11871,7 +12276,7 @@ S_regpatws( RExC_state_t *pRExC_state, char *p , const bool recognize_comment ) /* Returns the next non-pattern-white space, non-comment character (the * latter only if 'recognize_comment is true) in the string p, which is * ended by RExC_end. If there is no line break ending a comment, - * RExC_seen has added the REG_SEEN_RUN_ON_COMMENT flag; */ + * RExC_seen has added the REG_RUN_ON_COMMENT_SEEN flag; */ const char *e = RExC_end; PERL_ARGS_ASSERT_REGPATWS; @@ -11891,7 +12296,7 @@ S_regpatws( RExC_state_t *pRExC_state, char *p , const bool recognize_comment ) } } while (p < e); if (!ended) - RExC_seen |= REG_SEEN_RUN_ON_COMMENT; + RExC_seen |= REG_RUN_ON_COMMENT_SEEN; } else break; @@ -11945,8 +12350,8 @@ S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr) invlist_iterfinish(*invlist_ptr); /* Done with loop; remove any code points that are in the bitmap from - * *invlist_ptr; similarly for code points above latin1 if we have a flag - * to match all of them anyways */ + * *invlist_ptr; similarly for code points above latin1 if we have a + * flag to match all of them anyways */ if (change_invlist) { _invlist_subtract(*invlist_ptr, PL_Latin1, invlist_ptr); } @@ -12170,8 +12575,9 @@ S_could_it_be_a_POSIX_class(pTHX_ RExC_state_t *pRExC_state) } STATIC regnode * -S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist, I32 *flagp, U32 depth, - char * const oregcomp_parse) +S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist, + I32 *flagp, U32 depth, + char * const oregcomp_parse) { /* Handle the (?[...]) construct to do set operations */ @@ -12208,7 +12614,9 @@ S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist, I32 *f packWARN(WARN_EXPERIMENTAL__REGEX_SETS), "The regex_sets feature is experimental" REPORT_LOCATION, UTF8fARG(UTF, (RExC_parse - RExC_precomp), RExC_precomp), - UTF8fARG(UTF, RExC_end - RExC_start - (RExC_parse - RExC_precomp), RExC_precomp + (RExC_parse - RExC_precomp))); + UTF8fARG(UTF, + RExC_end - RExC_start - (RExC_parse - RExC_precomp), + RExC_precomp + (RExC_parse - RExC_precomp))); while (RExC_parse < RExC_end) { SV* current = NULL; @@ -12662,7 +13070,8 @@ S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist, I32 *f /* The names of properties whose definitions are not known at compile time are * stored in this SV, after a constant heading. So if the length has been * changed since initialization, then there is a run-time definition. */ -#define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION (SvCUR(listsv) != initial_listsv_len) +#define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION \ + (SvCUR(listsv) != initial_listsv_len) STATIC regnode * S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, @@ -12712,8 +13121,16 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more than just initialized. */ SV* properties = NULL; /* Code points that match \p{} \P{} */ - SV* posixes = NULL; /* Code points that match classes like, [:word:], - extended beyond the Latin1 range */ + SV* posixes = NULL; /* Code points that match classes like [:word:], + extended beyond the Latin1 range. These have to + be kept separate from other code points for much + of this function because their handling is + different under /i, and for most classes under + /d as well */ + SV* nposixes = NULL; /* Similarly for [:^word:]. These are kept + separate for a while from the non-complemented + versions because of complications with /d + matching */ UV element_count = 0; /* Number of distinct elements in the class. Optimizations may be possible if this is tiny */ AV * multi_char_matches = NULL; /* Code points that fold to more than one @@ -12740,11 +13157,14 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * string is in UTF-8. (Because is under /d) */ SV* depends_list = NULL; - /* inversion list of code points this node matches. For much of the - * function, it includes only those that match regardless of the utf8ness - * of the target string */ + /* Inversion list of code points this node matches regardless of things + * like locale, folding, utf8ness of the target string */ SV* cp_list = NULL; + /* Like cp_list, but code points on this list need to be checked for things + * that fold to/from them under /i */ + SV* cp_foldable_list = NULL; + #ifdef EBCDIC /* In a range, counts how many 0-2 of the ends of it came from literals, * not escapes. Thus we can tell if 'A' was input vs \x{C1} */ @@ -12752,9 +13172,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, #endif bool invert = FALSE; /* Is this class to be complemented */ - /* Is there any thing like \W or [:^digit:] that matches above the legal - * Unicode range? */ - bool runtime_posix_matches_above_Unicode = FALSE; + bool warn_super = ALWAYS_WARN_SUPER; regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in case we need to change the emitted regop to an EXACT. */ @@ -12905,7 +13323,7 @@ parseit: case 'H': namedclass = ANYOF_NHORIZWS; break; case 'N': /* Handle \N{NAME} in class */ { - /* We only pay attention to the first char of + /* We only pay attention to the first char of multichar strings being returned. I kinda wonder if this makes sense as it does change the behaviour from earlier versions, OTOH that behaviour was broken @@ -12926,7 +13344,12 @@ parseit: char *e; /* We will handle any undefined properties ourselves */ - U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF; + U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF + /* And we actually would prefer to get + * the straight inversion list of the + * swash, since we will be accessing it + * anyway, to save a little time */ + |_CORE_SWASH_INIT_ACCEPT_INVLIST; if (RExC_parse >= RExC_end) vFAIL2("Empty \\%c{}", (U8)value); @@ -13017,7 +13440,7 @@ parseit: * would cause things in to match * inappropriately, except that any \p{}, including * this one forces Unicode semantics, which means there - * is */ + * is no */ ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8; } else { @@ -13025,9 +13448,23 @@ parseit: /* Here, did get the swash and its inversion list. If * the swash is from a user-defined property, then this * whole character class should be regarded as such */ - has_user_defined_property = - (swash_init_flags - & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY); + if (swash_init_flags + & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY) + { + has_user_defined_property = TRUE; + } + else if + /* We warn on matching an above-Unicode code point + * if the match would return true, except don't + * warn for \p{All}, which has exactly one element + * = 0 */ + (_invlist_contains_cp(invlist, 0x110000) + && (! (_invlist_len(invlist) == 1 + && *invlist_array(invlist) == 0))) + { + warn_super = TRUE; + } + /* Invert if asking for the complement */ if (value == 'P') { @@ -13101,7 +13538,7 @@ parseit: goto recode_encoding; break; case 'c': - value = grok_bslash_c(*RExC_parse++, UTF, SIZE_ONLY); + value = grok_bslash_c(*RExC_parse++, SIZE_ONLY); break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': @@ -13181,21 +13618,37 @@ parseit: * space will contain a bit for each named class that is to be matched * against. This isn't needed for \p{} and pseudo-classes, as they are * not affected by locale, and hence are dealt with separately */ - if (LOC - && ! need_class - && (ANYOF_LOCALE == ANYOF_POSIXL - || (namedclass > OOB_NAMEDCLASS - && namedclass < ANYOF_POSIXL_MAX))) - { - need_class = 1; - if (SIZE_ONLY) { - RExC_size += ANYOF_POSIXL_SKIP - ANYOF_SKIP; + if (LOC) { + if (FOLD && ! need_class) { + need_class = 1; + if (SIZE_ONLY) { + RExC_size += ANYOF_POSIXL_FOLD_SKIP - ANYOF_SKIP; + } + else { + RExC_emit += ANYOF_POSIXL_FOLD_SKIP - ANYOF_SKIP; + } + + /* We need to initialize this here because this node type has + * this field, and will skip getting initialized when we get to + * a posix class since are doing it here */ + ANYOF_POSIXL_ZERO(ret); } - else { - RExC_emit += ANYOF_POSIXL_SKIP - ANYOF_SKIP; + if (ANYOF_LOCALE == ANYOF_POSIXL + || (namedclass > OOB_NAMEDCLASS + && namedclass < ANYOF_POSIXL_MAX)) + { + if (! need_class) { + need_class = 1; + if (SIZE_ONLY) { + RExC_size += ANYOF_POSIXL_SKIP - ANYOF_SKIP; + } + else { + RExC_emit += ANYOF_POSIXL_SKIP - ANYOF_SKIP; + } + ANYOF_POSIXL_ZERO(ret); + } + ANYOF_FLAGS(ret) |= ANYOF_POSIXL; } - ANYOF_POSIXL_ZERO(ret); - ANYOF_FLAGS(ret) |= ANYOF_POSIXL; } if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */ @@ -13221,7 +13674,8 @@ parseit: UTF8fARG(UTF, w, rangebegin)); (void)ReREFCNT_inc(RExC_rx_sv); cp_list = add_cp_to_invlist(cp_list, '-'); - cp_list = add_cp_to_invlist(cp_list, prevvalue); + cp_foldable_list = add_cp_to_invlist(cp_foldable_list, + prevvalue); } } @@ -13235,32 +13689,65 @@ parseit: #ifndef HAS_ISASCII && classnum != _CC_ASCII #endif -#ifndef HAS_ISBLANK - && classnum != _CC_BLANK -#endif ) { + + /* See if it already matches the complement of this POSIX + * class */ if ((ANYOF_FLAGS(ret) & ANYOF_POSIXL) && ANYOF_POSIXL_TEST(ret, namedclass + ((namedclass % 2) ? -1 : 1))) { posixl_matches_all = TRUE; - break; + break; /* No need to continue. Since it matches both + e.g., \w and \W, it matches everything, and the + bracketed class can be optimized into qr/./s */ } + + /* Add this class to those that should be checked at runtime */ ANYOF_POSIXL_SET(ret, namedclass); + + /* The above-Latin1 characters are not subject to locale rules. + * Just add them, in the second pass, to the + * unconditionally-matched list */ + if (! SIZE_ONLY) { + SV* scratch_list = NULL; + + /* Get the list of the above-Latin1 code points this + * matches */ + _invlist_intersection_maybe_complement_2nd(PL_AboveLatin1, + PL_XPosix_ptrs[classnum], + + /* Odd numbers are complements, like + * NDIGIT, NASCII, ... */ + namedclass % 2 != 0, + &scratch_list); + /* Checking if 'cp_list' is NULL first saves an extra + * clone. Its reference count will be decremented at the + * next union, etc, or if this is the only instance, at the + * end of the routine */ + if (! cp_list) { + cp_list = scratch_list; + } + else { + _invlist_union(cp_list, scratch_list, &cp_list); + SvREFCNT_dec_NN(scratch_list); + } + continue; /* Go get next character */ + } } - /* XXX After have made all the posix classes known at compile time - * we can move the LOC handling below to above */ + else if (! SIZE_ONLY) { - if (! SIZE_ONLY) { + /* Here, not in pass1 (in that pass we skip calculating the + * contents of this class), and is /l, or is a POSIX class for + * which /l doesn't matter (or is a Unicode property, which is + * skipped here). */ if (namedclass >= ANYOF_POSIXL_MAX) { /* If a special class */ if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */ - /* Here, should be \h, \H, \v, or \V. Neither /d nor - * /l make a difference in what these match. There - * would be problems if these characters had folds - * other than themselves, as cp_list is subject to - * folding. */ + /* Here, should be \h, \H, \v, or \V. None of /d, /i + * nor /l make a difference in what these match, + * therefore we just add what they match to cp_list. */ if (classnum != _CC_VERTSPACE) { assert( namedclass == ANYOF_HORIZWS || namedclass == ANYOF_NHORIZWS); @@ -13273,246 +13760,25 @@ parseit: _invlist_union_maybe_complement_2nd( cp_list, PL_XPosix_ptrs[classnum], - cBOOL(namedclass % 2), /* Complement if odd + namedclass % 2 != 0, /* Complement if odd (NHORIZWS, NVERTWS) */ &cp_list); } } - else if (classnum == _CC_ASCII) { -#ifdef HAS_ISASCII - if (LOC) { - ANYOF_POSIXL_SET(ret, namedclass); - } - else -#endif /* Not isascii(); just use the hard-coded definition for it */ - _invlist_union_maybe_complement_2nd( - posixes, - PL_Posix_ptrs[_CC_ASCII], - cBOOL(namedclass % 2), /* Complement if odd - (NASCII) */ - &posixes); - } - else { /* Garden variety class */ - - /* The ascii range inversion list */ - SV* ascii_source = PL_Posix_ptrs[classnum]; - - /* The full Latin1 range inversion list */ - SV* l1_source = PL_L1Posix_ptrs[classnum]; - - /* This code is structured into two major clauses. The - * first is for classes whose complete definitions may not - * already be known. If not, the Latin1 definition - * (guaranteed to already known) is used plus code is - * generated to load the rest at run-time (only if needed). - * If the complete definition is known, it drops down to - * the second clause, where the complete definition is - * known */ - - if (classnum < _FIRST_NON_SWASH_CC) { - - /* Here, the class has a swash, which may or not - * already be loaded */ - - /* The name of the property to use to match the full - * eXtended Unicode range swash for this character - * class */ - const char *Xname = swash_property_names[classnum]; - - /* If returning the inversion list, we can't defer - * getting this until runtime */ - if (ret_invlist && ! PL_utf8_swash_ptrs[classnum]) { - PL_utf8_swash_ptrs[classnum] = - _core_swash_init("utf8", Xname, &PL_sv_undef, - 1, /* binary */ - 0, /* not tr/// */ - NULL, /* No inversion list */ - NULL /* No flags */ - ); - assert(PL_utf8_swash_ptrs[classnum]); - } - if ( ! PL_utf8_swash_ptrs[classnum]) { - if (namedclass % 2 == 0) { /* A non-complemented - class */ - /* If not /a matching, there are code points we - * don't know at compile time. Arrange for the - * unknown matches to be loaded at run-time, if - * needed */ - if (! AT_LEAST_ASCII_RESTRICTED) { - Perl_sv_catpvf(aTHX_ listsv, "+utf8::%s\n", - Xname); - } - if (LOC) { /* Under locale, set run-time - lookup */ - ANYOF_POSIXL_SET(ret, namedclass); - } - else { - /* Add the current class's code points to - * the running total */ - _invlist_union(posixes, - (AT_LEAST_ASCII_RESTRICTED) - ? ascii_source - : l1_source, - &posixes); - } - } - else { /* A complemented class */ - if (AT_LEAST_ASCII_RESTRICTED) { - /* Under /a should match everything above - * ASCII, plus the complement of the set's - * ASCII matches */ - _invlist_union_complement_2nd(posixes, - ascii_source, - &posixes); - } - else { - /* Arrange for the unknown matches to be - * loaded at run-time, if needed */ - Perl_sv_catpvf(aTHX_ listsv, "!utf8::%s\n", - Xname); - runtime_posix_matches_above_Unicode = TRUE; - if (LOC) { - ANYOF_POSIXL_SET(ret, namedclass); - } - else { - - /* We want to match everything in - * Latin1, except those things that - * l1_source matches */ - SV* scratch_list = NULL; - _invlist_subtract(PL_Latin1, l1_source, - &scratch_list); - - /* Add the list from this class to the - * running total */ - if (! posixes) { - posixes = scratch_list; - } - else { - _invlist_union(posixes, - scratch_list, - &posixes); - SvREFCNT_dec_NN(scratch_list); - } - if (DEPENDS_SEMANTICS) { - ANYOF_FLAGS(ret) - |= ANYOF_NON_UTF8_LATIN1_ALL; - } - } - } - } - goto namedclass_done; - } - - /* Here, there is a swash loaded for the class. If no - * inversion list for it yet, get it */ - if (! PL_XPosix_ptrs[classnum]) { - PL_XPosix_ptrs[classnum] - = _swash_to_invlist(PL_utf8_swash_ptrs[classnum]); - } - } - - /* Here there is an inversion list already loaded for the - * entire class */ - - if (namedclass % 2 == 0) { /* A non-complemented class, - like ANYOF_PUNCT */ - if (! LOC) { - /* For non-locale, just add it to any existing list - * */ - _invlist_union(posixes, - (AT_LEAST_ASCII_RESTRICTED) - ? ascii_source - : PL_XPosix_ptrs[classnum], - &posixes); - } - else { /* Locale */ - SV* scratch_list = NULL; - - /* For above Latin1 code points, we use the full - * Unicode range */ - _invlist_intersection(PL_AboveLatin1, - PL_XPosix_ptrs[classnum], - &scratch_list); - /* And set the output to it, adding instead if - * there already is an output. Checking if - * 'posixes' is NULL first saves an extra clone. - * Its reference count will be decremented at the - * next union, etc, or if this is the only - * instance, at the end of the routine */ - if (! posixes) { - posixes = scratch_list; - } - else { - _invlist_union(posixes, scratch_list, &posixes); - SvREFCNT_dec_NN(scratch_list); - } - -#ifndef HAS_ISBLANK - if (namedclass != ANYOF_BLANK) { -#endif - /* Set this class in the node for runtime - * matching */ - ANYOF_POSIXL_SET(ret, namedclass); -#ifndef HAS_ISBLANK - } - else { - /* No isblank(), use the hard-coded ASCII-range - * blanks, adding them to the running total. */ - - _invlist_union(posixes, ascii_source, &posixes); - } -#endif - } - } - else { /* A complemented class, like ANYOF_NPUNCT */ - if (! LOC) { - _invlist_union_complement_2nd( - posixes, - (AT_LEAST_ASCII_RESTRICTED) - ? ascii_source - : PL_XPosix_ptrs[classnum], - &posixes); - /* Under /d, everything in the upper half of the - * Latin1 range matches this complement */ - if (DEPENDS_SEMANTICS) { - ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL; - } - } - else { /* Locale */ - SV* scratch_list = NULL; - _invlist_subtract(PL_AboveLatin1, - PL_XPosix_ptrs[classnum], - &scratch_list); - if (! posixes) { - posixes = scratch_list; - } - else { - _invlist_union(posixes, scratch_list, &posixes); - SvREFCNT_dec_NN(scratch_list); - } -#ifndef HAS_ISBLANK - if (namedclass != ANYOF_NBLANK) { -#endif - ANYOF_POSIXL_SET(ret, namedclass); -#ifndef HAS_ISBLANK - } - else { - /* Get the list of all code points in Latin1 - * that are not ASCII blanks, and add them to - * the running total */ - _invlist_subtract(PL_Latin1, ascii_source, - &scratch_list); - _invlist_union(posixes, scratch_list, &posixes); - SvREFCNT_dec_NN(scratch_list); - } -#endif - } - } + else { /* Garden variety class. If is NASCII, NDIGIT, ... + complement and use nposixes */ + SV** posixes_ptr = namedclass % 2 == 0 + ? &posixes + : &nposixes; + SV** source_ptr = &PL_XPosix_ptrs[classnum]; + _invlist_union_maybe_complement_2nd( + *posixes_ptr, + *source_ptr, + namedclass % 2 != 0, + posixes_ptr); } - namedclass_done: - continue; /* Go get next character */ + continue; /* Go get next character */ } } /* end of namedclass \blah */ @@ -13614,11 +13880,9 @@ parseit: value, foldbuf, &foldlen, - FOLD_FLAGS_FULL - | ((LOC) ? FOLD_FLAGS_LOCALE - : (ASCII_FOLD_RESTRICTED) - ? FOLD_FLAGS_NOMIX_ASCII - : 0) + FOLD_FLAGS_FULL | (ASCII_FOLD_RESTRICTED + ? FOLD_FLAGS_NOMIX_ASCII + : 0) ); /* Here, should be the first character of the @@ -13686,7 +13950,8 @@ parseit: /* Deal with this element of the class */ if (! SIZE_ONLY) { #ifndef EBCDIC - cp_list = _add_range_to_invlist(cp_list, prevvalue, value); + cp_foldable_list = _add_range_to_invlist(cp_foldable_list, + prevvalue, value); #else SV* this_range = _new_invlist(1); _append_range_to_invlist(this_range, prevvalue, value); @@ -13705,10 +13970,13 @@ parseit: { _invlist_intersection(this_range, PL_ASCII, &this_range); - _invlist_intersection(this_range, PL_Posix_ptrs[_CC_ALPHA], + + /* Since this above only contains ascii, the intersection of it + * with anything will still yield only ascii */ + _invlist_intersection(this_range, PL_XPosix_ptrs[_CC_ALPHA], &this_range); } - _invlist_union(cp_list, this_range, &cp_list); + _invlist_union(cp_foldable_list, this_range, &cp_foldable_list); literal_endpoint = 0; #endif } @@ -13793,11 +14061,19 @@ parseit: return ret; } - /* If the character class contains only a single element, it may be - * optimizable into another node type which is smaller and runs faster. - * Check if this is the case for this class */ - if ((element_count == 1 && ! ret_invlist) - || UNLIKELY(posixl_matches_all)) + /* Here, we've gone through the entire class and dealt with multi-char + * folds. We are now in a position that we can do some checks to see if we + * can optimize this ANYOF node into a simpler one, even in Pass 1. + * Currently we only do two checks: + * 1) is in the unlikely event that the user has specified both, eg. \w and + * \W under /l, then the class matches everything. (This optimization + * is done only to make the optimizer code run later work.) + * 2) if the character class contains only a single element (including a + * single range), we see if there is an equivalent node for it. + * Other checks are possible */ + if (! ret_invlist /* Can't optimize if returning the constructed + inversion list */ + && (UNLIKELY(posixl_matches_all) || element_count == 1)) { U8 op = END; U8 arg = 0; @@ -13863,14 +14139,6 @@ parseit: if (op > POSIXA) { /* /aa is same as /a */ op = POSIXA; } -#ifndef HAS_ISBLANK - if (op == POSIXL - && (namedclass == ANYOF_BLANK - || namedclass == ANYOF_NBLANK)) - { - op = POSIXA; - } -#endif join_posix: /* The odd numbered ones are the complements of the @@ -13953,7 +14221,9 @@ parseit: RExC_parse = (char *) cur_parse; SvREFCNT_dec(posixes); + SvREFCNT_dec(nposixes); SvREFCNT_dec(cp_list); + SvREFCNT_dec(cp_foldable_list); return ret; } } @@ -13964,46 +14234,40 @@ parseit: /* If folding, we calculate all characters that could fold to or from the * ones already on the list */ - if (FOLD && cp_list) { - UV start, end; /* End points of code point ranges */ + if (cp_foldable_list) { + if (FOLD) { + UV start, end; /* End points of code point ranges */ + + SV* fold_intersection = NULL; + SV** use_list; + + /* Our calculated list will be for Unicode rules. For locale + * matching, we have to keep a separate list that is consulted at + * runtime only when the locale indicates Unicode rules. For + * non-locale, we just use to the general list */ + if (LOC) { + use_list = &ANYOF_UTF8_LOCALE_INVLIST(ret); + *use_list = NULL; + } + else { + use_list = &cp_list; + } - SV* fold_intersection = NULL; + /* Only the characters in this class that participate in folds need + * be checked. Get the intersection of this class and all the + * possible characters that are foldable. This can quickly narrow + * down a large class */ + _invlist_intersection(PL_utf8_foldable, cp_foldable_list, + &fold_intersection); - /* If the highest code point is within Latin1, we can use the - * compiled-in Alphas list, and not have to go out to disk. This - * yields two false positives, the masculine and feminine ordinal - * indicators, which are weeded out below using the - * IS_IN_SOME_FOLD_L1() macro */ - if (invlist_highest(cp_list) < 256) { - _invlist_intersection(PL_L1Posix_ptrs[_CC_ALPHA], cp_list, - &fold_intersection); - } - else { + /* The folds for all the Latin1 characters are hard-coded into this + * program, but we have to go out to disk to get the others. */ + if (invlist_highest(cp_foldable_list) >= 256) { + + /* This is a hash that for a particular fold gives all + * characters that are involved in it */ + if (! PL_utf8_foldclosures) { - /* Here, there are non-Latin1 code points, so we will have to go - * fetch the list of all the characters that participate in folds - */ - if (! PL_utf8_foldable) { - SV* swash = swash_init("utf8", "_Perl_Any_Folds", - &PL_sv_undef, 1, 0); - PL_utf8_foldable = _get_swash_invlist(swash); - SvREFCNT_dec_NN(swash); - } - - /* This is a hash that for a particular fold gives all characters - * that are involved in it */ - if (! PL_utf8_foldclosures) { - - /* If we were unable to find any folds, then we likely won't be - * able to find the closures. So just create an empty list. - * Folding will effectively be restricted to the non-Unicode - * rules hard-coded into Perl. (This case happens legitimately - * during compilation of Perl itself before the Unicode tables - * are generated) */ - if (_invlist_len(PL_utf8_foldable) == 0) { - PL_utf8_foldclosures = newHV(); - } - else { /* If the folds haven't been read in, call a fold function * to force that */ if (! PL_utf8_tofold) { @@ -14013,189 +14277,218 @@ parseit: to_utf8_fold((U8*) HYPHEN_UTF8, dummy, NULL); assert(PL_utf8_tofold); /* Verify that worked */ } - PL_utf8_foldclosures = - _swash_inversion_hash(PL_utf8_tofold); + PL_utf8_foldclosures + = _swash_inversion_hash(PL_utf8_tofold); } } - /* Only the characters in this class that participate in folds need - * be checked. Get the intersection of this class and all the - * possible characters that are foldable. This can quickly narrow - * down a large class */ - _invlist_intersection(PL_utf8_foldable, cp_list, - &fold_intersection); - } - - /* Now look at the foldable characters in this class individually */ - invlist_iterinit(fold_intersection); - while (invlist_iternext(fold_intersection, &start, &end)) { - UV j; - - /* Locale folding for Latin1 characters is deferred until runtime */ - if (LOC && start < 256) { - start = 256; - } - - /* Look at every character in the range */ - for (j = start; j <= end; j++) { - - U8 foldbuf[UTF8_MAXBYTES_CASE+1]; - STRLEN foldlen; - SV** listp; - - if (j < 256) { - - /* We have the latin1 folding rules hard-coded here so that - * an innocent-looking character class, like /[ks]/i won't - * have to go out to disk to find the possible matches. - * XXX It would be better to generate these via regen, in - * case a new version of the Unicode standard adds new - * mappings, though that is not really likely, and may be - * caught by the default: case of the switch below. */ - - if (IS_IN_SOME_FOLD_L1(j)) { - - /* ASCII is always matched; non-ASCII is matched only - * under Unicode rules */ - if (isASCII(j) || AT_LEAST_UNI_SEMANTICS) { - cp_list = - add_cp_to_invlist(cp_list, PL_fold_latin1[j]); - } - else { - depends_list = - add_cp_to_invlist(depends_list, PL_fold_latin1[j]); + /* Now look at the foldable characters in this class individually */ + invlist_iterinit(fold_intersection); + while (invlist_iternext(fold_intersection, &start, &end)) { + UV j; + + /* Look at every character in the range */ + for (j = start; j <= end; j++) { + U8 foldbuf[UTF8_MAXBYTES_CASE+1]; + STRLEN foldlen; + SV** listp; + + if (j < 256) { + + /* We have the latin1 folding rules hard-coded here so + * that an innocent-looking character class, like + * /[ks]/i won't have to go out to disk to find the + * possible matches. XXX It would be better to + * generate these via regen, in case a new version of + * the Unicode standard adds new mappings, though that + * is not really likely, and may be caught by the + * default: case of the switch below. */ + + if (IS_IN_SOME_FOLD_L1(j)) { + + /* ASCII is always matched; non-ASCII is matched + * only under Unicode rules (which could happen + * under /l if the locale is a UTF-8 one */ + if (isASCII(j) || ! DEPENDS_SEMANTICS) { + *use_list = add_cp_to_invlist(*use_list, + PL_fold_latin1[j]); + } + else { + depends_list = + add_cp_to_invlist(depends_list, + PL_fold_latin1[j]); + } } - } - if (HAS_NONLATIN1_FOLD_CLOSURE(j) - && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED)) - { - /* Certain Latin1 characters have matches outside - * Latin1. To get here, is one of those - * characters. None of these matches is valid for - * ASCII characters under /aa, which is why the 'if' - * just above excludes those. These matches only - * happen when the target string is utf8. The code - * below adds the single fold closures for to the - * inversion list. */ - switch (j) { - case 'k': - case 'K': - cp_list = - add_cp_to_invlist(cp_list, KELVIN_SIGN); - break; - case 's': - case 'S': - cp_list = add_cp_to_invlist(cp_list, + if (HAS_NONLATIN1_FOLD_CLOSURE(j) + && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED)) + { + /* Certain Latin1 characters have matches outside + * Latin1. To get here, is one of those + * characters. None of these matches is valid for + * ASCII characters under /aa, which is why the 'if' + * just above excludes those. These matches only + * happen when the target string is utf8. The code + * below adds the single fold closures for to the + * inversion list. */ + + switch (j) { + case 'k': + case 'K': + *use_list = + add_cp_to_invlist(*use_list, KELVIN_SIGN); + break; + case 's': + case 'S': + *use_list = add_cp_to_invlist(*use_list, LATIN_SMALL_LETTER_LONG_S); - break; - case MICRO_SIGN: - cp_list = add_cp_to_invlist(cp_list, - GREEK_CAPITAL_LETTER_MU); - cp_list = add_cp_to_invlist(cp_list, - GREEK_SMALL_LETTER_MU); - break; - case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE: - case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE: - cp_list = - add_cp_to_invlist(cp_list, ANGSTROM_SIGN); - break; - case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS: - cp_list = add_cp_to_invlist(cp_list, + break; + case MICRO_SIGN: + *use_list = add_cp_to_invlist(*use_list, + GREEK_CAPITAL_LETTER_MU); + *use_list = add_cp_to_invlist(*use_list, + GREEK_SMALL_LETTER_MU); + break; + case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE: + case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE: + *use_list = + add_cp_to_invlist(*use_list, ANGSTROM_SIGN); + break; + case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS: + *use_list = add_cp_to_invlist(*use_list, LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); - break; - case LATIN_SMALL_LETTER_SHARP_S: - cp_list = add_cp_to_invlist(cp_list, - LATIN_CAPITAL_LETTER_SHARP_S); - break; - case 'F': case 'f': - case 'I': case 'i': - case 'L': case 'l': - case 'T': case 't': - case 'A': case 'a': - case 'H': case 'h': - case 'J': case 'j': - case 'N': case 'n': - case 'W': case 'w': - case 'Y': case 'y': - /* These all are targets of multi-character - * folds from code points that require UTF8 to - * express, so they can't match unless the - * target string is in UTF-8, so no action here - * is necessary, as regexec.c properly handles - * the general case for UTF-8 matching and - * multi-char folds */ - break; - default: - /* Use deprecated warning to increase the - * chances of this being output */ - ckWARN2reg_d(RExC_parse, "Perl folding rules are not up-to-date for 0x%"UVXf"; please use the perlbug utility to report;", j); - break; + break; + case LATIN_SMALL_LETTER_SHARP_S: + *use_list = add_cp_to_invlist(*use_list, + LATIN_CAPITAL_LETTER_SHARP_S); + break; + case 'F': case 'f': + case 'I': case 'i': + case 'L': case 'l': + case 'T': case 't': + case 'A': case 'a': + case 'H': case 'h': + case 'J': case 'j': + case 'N': case 'n': + case 'W': case 'w': + case 'Y': case 'y': + /* These all are targets of multi-character + * folds from code points that require UTF8 + * to express, so they can't match unless + * the target string is in UTF-8, so no + * action here is necessary, as regexec.c + * properly handles the general case for + * UTF-8 matching and multi-char folds */ + break; + default: + /* Use deprecated warning to increase the + * chances of this being output */ + ckWARN2reg_d(RExC_parse, "Perl folding rules are not up-to-date for 0x%"UVXf"; please use the perlbug utility to report;", j); + break; + } } + continue; } - continue; - } - /* Here is an above Latin1 character. We don't have the rules - * hard-coded for it. First, get its fold. This is the simple - * fold, as the multi-character folds have been handled earlier - * and separated out */ - _to_uni_fold_flags(j, foldbuf, &foldlen, - ((LOC) - ? FOLD_FLAGS_LOCALE - : (ASCII_FOLD_RESTRICTED) - ? FOLD_FLAGS_NOMIX_ASCII - : 0)); - - /* Single character fold of above Latin1. Add everything in - * its fold closure to the list that this node should match. - * The fold closures data structure is a hash with the keys - * being the UTF-8 of every character that is folded to, like - * 'k', and the values each an array of all code points that - * fold to its key. e.g. [ 'k', 'K', KELVIN_SIGN ]. - * Multi-character folds are not included */ - if ((listp = hv_fetch(PL_utf8_foldclosures, - (char *) foldbuf, foldlen, FALSE))) - { - AV* list = (AV*) *listp; - IV k; - for (k = 0; k <= av_len(list); k++) { - SV** c_p = av_fetch(list, k, FALSE); - UV c; - if (c_p == NULL) { - Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure"); - } - c = SvUV(*c_p); - - /* /aa doesn't allow folds between ASCII and non-; /l - * doesn't allow them between above and below 256 */ - if ((ASCII_FOLD_RESTRICTED - && (isASCII(c) != isASCII(j))) - || (LOC && c < 256)) { - continue; - } + /* Here is an above Latin1 character. We don't have the + * rules hard-coded for it. First, get its fold. This is + * the simple fold, as the multi-character folds have been + * handled earlier and separated out */ + _to_uni_fold_flags(j, foldbuf, &foldlen, + (ASCII_FOLD_RESTRICTED) + ? FOLD_FLAGS_NOMIX_ASCII + : 0); + + /* Single character fold of above Latin1. Add everything in + * its fold closure to the list that this node should match. + * The fold closures data structure is a hash with the keys + * being the UTF-8 of every character that is folded to, like + * 'k', and the values each an array of all code points that + * fold to its key. e.g. [ 'k', 'K', KELVIN_SIGN ]. + * Multi-character folds are not included */ + if ((listp = hv_fetch(PL_utf8_foldclosures, + (char *) foldbuf, foldlen, FALSE))) + { + AV* list = (AV*) *listp; + IV k; + for (k = 0; k <= av_len(list); k++) { + SV** c_p = av_fetch(list, k, FALSE); + UV c; + if (c_p == NULL) { + Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure"); + } + c = SvUV(*c_p); - /* Folds involving non-ascii Latin1 characters - * under /d are added to a separate list */ - if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS) - { - cp_list = add_cp_to_invlist(cp_list, c); - } - else { - depends_list = add_cp_to_invlist(depends_list, c); + /* /aa doesn't allow folds between ASCII and non- */ + if ((ASCII_FOLD_RESTRICTED + && (isASCII(c) != isASCII(j)))) + { + continue; + } + + /* Folds under /l which cross the 255/256 boundary + * are added to a separate list. (These are valid + * only when the locale is UTF-8.) */ + if (c < 256 && LOC) { + *use_list = add_cp_to_invlist(*use_list, c); + continue; + } + + if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS) + { + cp_list = add_cp_to_invlist(cp_list, c); + } + else { + /* Similarly folds involving non-ascii Latin1 + * characters under /d are added to their list */ + depends_list = add_cp_to_invlist(depends_list, + c); + } } } } } - } - SvREFCNT_dec_NN(fold_intersection); + SvREFCNT_dec_NN(fold_intersection); + } + + /* Now that we have finished adding all the folds, there is no reason + * to keep the foldable list separate */ + _invlist_union(cp_list, cp_foldable_list, &cp_list); + SvREFCNT_dec_NN(cp_foldable_list); } /* And combine the result (if any) with any inversion list from posix * classes. The lists are kept separate up to now because we don't want to * fold the classes (folding of those is automatically handled by the swash * fetching code) */ - if (posixes) { + if (posixes || nposixes) { + if (posixes && AT_LEAST_ASCII_RESTRICTED) { + /* Under /a and /aa, nothing above ASCII matches these */ + _invlist_intersection(posixes, + PL_XPosix_ptrs[_CC_ASCII], + &posixes); + } + if (nposixes) { + if (DEPENDS_SEMANTICS) { + /* Under /d, everything in the upper half of the Latin1 range + * matches these complements */ + OP(ret) = ANYOF_NON_UTF8_NON_ASCII_ALL; + } + else if (AT_LEAST_ASCII_RESTRICTED) { + /* Under /a and /aa, everything above ASCII matches these + * complements */ + _invlist_union_complement_2nd(nposixes, + PL_XPosix_ptrs[_CC_ASCII], + &nposixes); + } + if (posixes) { + _invlist_union(posixes, nposixes, &posixes); + SvREFCNT_dec_NN(nposixes); + } + else { + posixes = nposixes; + } + } if (! DEPENDS_SEMANTICS) { if (cp_list) { _invlist_union(cp_list, posixes, &cp_list); @@ -14244,7 +14537,6 @@ parseit: * , because having a Unicode property forces Unicode * semantics */ if (properties) { - bool warn_super = ! has_user_defined_property; if (cp_list) { /* If it matters to the final outcome, see if a non-property @@ -14255,14 +14547,8 @@ parseit: * are using above-Unicode code points indicates they should know * the issues involved */ if (warn_super) { - bool non_prop_matches_above_Unicode = - runtime_posix_matches_above_Unicode - | (invlist_highest(cp_list) > PERL_UNICODE_MAX); - if (invert) { - non_prop_matches_above_Unicode = - ! non_prop_matches_above_Unicode; - } - warn_super = ! non_prop_matches_above_Unicode; + warn_super = ! (invert + ^ (invlist_highest(cp_list) > PERL_UNICODE_MAX)); } _invlist_union(properties, cp_list, &cp_list); @@ -14273,7 +14559,7 @@ parseit: } if (warn_super) { - OP(ret) = ANYOF_WARN_SUPER; + ANYOF_FLAGS(ret) |= ANYOF_WARN_SUPER; } } @@ -14286,12 +14572,32 @@ parseit: * shouldn't. Therefore we can't invert folded locale now, as it won't be * folded until runtime */ + /* If we didn't do folding, it's because some information isn't available + * until runtime; set the run-time fold flag for these. (We don't have to + * worry about properties folding, as that is taken care of by the swash + * fetching). We know to set the flag if we have a non-NULL list for UTF-8 + * locales, or the class matches at least one 0-255 range code point */ + if (LOC && FOLD) { + if (ANYOF_UTF8_LOCALE_INVLIST(ret)) { + ANYOF_FLAGS(ret) |= ANYOF_LOC_FOLD; + } + else if (cp_list) { /* Look to see if there a 0-255 code point is in + the list */ + UV start, end; + invlist_iterinit(cp_list); + if (invlist_iternext(cp_list, &start, &end) && start < 256) { + ANYOF_FLAGS(ret) |= ANYOF_LOC_FOLD; + } + invlist_iterfinish(cp_list); + } + } + /* Optimize inverted simple patterns (e.g. [^a-z]) when everything is known * at compile time. Besides not inverting folded locale now, we can't * invert if there are things such as \w, which aren't known until runtime * */ if (invert - && ! (LOC && (FOLD || (ANYOF_FLAGS(ret) & ANYOF_POSIXL))) + && ! (ANYOF_FLAGS(ret) & (ANYOF_LOC_FOLD|ANYOF_POSIXL)) && ! depends_list && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION) { @@ -14321,15 +14627,6 @@ parseit: return orig_emit; } - /* If we didn't do folding, it's because some information isn't available - * until runtime; set the run-time fold flag for these. (We don't have to - * worry about properties folding, as that is taken care of by the swash - * fetching) */ - if (FOLD && LOC) - { - ANYOF_FLAGS(ret) |= ANYOF_LOC_FOLD; - } - /* Some character classes are equivalent to other nodes. Such nodes take * up less room and generally fewer operations to execute than ANYOF nodes. * Above, we checked for and optimized into some such equivalents for @@ -14348,8 +14645,13 @@ parseit: if (cp_list && ! invert && ! depends_list - && ! (ANYOF_FLAGS(ret) & ANYOF_POSIXL) - && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION) + && ! (ANYOF_FLAGS(ret) & (ANYOF_LOC_FOLD|ANYOF_POSIXL)) + && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION + + /* We don't optimize if we are supposed to make sure all non-Unicode + * code points raise a warning, as only ANYOF nodes have this check. + * */ + && ! ((ANYOF_FLAGS(ret) | ANYOF_WARN_SUPER) && ALWAYS_WARN_SUPER)) { UV start, end; U8 op = END; /* The optimzation node-type */ @@ -14373,7 +14675,7 @@ parseit: && (start < 256 || UTF)) { /* Here, the list contains a single code point. Can optimize - * into an EXACT node */ + * into an EXACTish node */ value = start; @@ -14403,12 +14705,6 @@ parseit: } } else { - if (! PL_utf8_foldable) { - SV* swash = swash_init("utf8", "_Perl_Any_Folds", - &PL_sv_undef, 1, 0); - PL_utf8_foldable = _get_swash_invlist(swash); - SvREFCNT_dec_NN(swash); - } if (_invlist_contains_cp(PL_utf8_foldable, value)) { op = EXACT; } @@ -14564,7 +14860,7 @@ S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state, Absorbs an /x style # comments from the input stream. Returns true if there is more text remaining in the stream. - Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment + Will set the REG_RUN_ON_COMMENT_SEEN flag if the comment terminates the pattern without including a newline. Note its the callers responsibility to ensure that we are @@ -14587,7 +14883,7 @@ S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state) if (!ended) { /* we ran off the end of the pattern without ending the comment, so we have to add an \n when wrapping */ - RExC_seen |= REG_SEEN_RUN_ON_COMMENT; + RExC_seen |= REG_RUN_ON_COMMENT_SEEN; return 0; } else return 1; @@ -14668,14 +14964,15 @@ S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op) FILL_ADVANCE_NODE(ptr, op); #ifdef RE_TRACK_PATTERN_OFFSETS if (RExC_offsets) { /* MJD */ - MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n", - "reg_node", __LINE__, + MJD_OFFSET_DEBUG( + ("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n", + "reg_node", __LINE__, PL_reg_name[op], - (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] + (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? "Overwriting end of array!\n" : "OK", (UV)(RExC_emit - RExC_emit_start), (UV)(RExC_parse - RExC_start), - (UV)RExC_offsets[0])); + (UV)RExC_offsets[0])); Set_Node_Offset(RExC_emit, RExC_parse + (op == END)); } #endif @@ -14699,16 +14996,16 @@ S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg) if (SIZE_ONLY) { SIZE_ALIGN(RExC_size); RExC_size += 2; - /* + /* We can't do this: - - assert(2==regarglen[op]+1); + + assert(2==regarglen[op]+1); Anything larger than this has to allocate the extra amount. If we changed this to be: - + RExC_size += (1 + regarglen[op]); - + then it wouldn't matter. Its not clear what side effect might come from that so its not done so far. -- dmq @@ -14724,18 +15021,19 @@ S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg) FILL_ADVANCE_NODE_ARG(ptr, op, arg); #ifdef RE_TRACK_PATTERN_OFFSETS if (RExC_offsets) { /* MJD */ - MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", + MJD_OFFSET_DEBUG( + ("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", "reganode", __LINE__, PL_reg_name[op], - (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? + (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? "Overwriting end of array!\n" : "OK", (UV)(RExC_emit - RExC_emit_start), (UV)(RExC_parse - RExC_start), - (UV)RExC_offsets[0])); + (UV)RExC_offsets[0])); Set_Cur_Node_Offset; } -#endif +#endif RExC_emit = ptr; return(ret); } @@ -14743,7 +15041,7 @@ S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg) /* - reguni - emit (if appropriate) a Unicode character */ -STATIC STRLEN +PERL_STATIC_INLINE STRLEN S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s) { dVAR; @@ -14804,30 +15102,32 @@ S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth) StructCopy(--src, --dst, regnode); #ifdef RE_TRACK_PATTERN_OFFSETS if (RExC_offsets) { /* MJD 20010112 */ - MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n", + MJD_OFFSET_DEBUG( + ("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n", "reg_insert", __LINE__, PL_reg_name[op], - (UV)(dst - RExC_emit_start) > RExC_offsets[0] + (UV)(dst - RExC_emit_start) > RExC_offsets[0] ? "Overwriting end of array!\n" : "OK", (UV)(src - RExC_emit_start), (UV)(dst - RExC_emit_start), - (UV)RExC_offsets[0])); + (UV)RExC_offsets[0])); Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src)); Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src)); } #endif } - + place = opnd; /* Op node, where operand used to be. */ #ifdef RE_TRACK_PATTERN_OFFSETS if (RExC_offsets) { /* MJD */ - MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", + MJD_OFFSET_DEBUG( + ("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", "reginsert", __LINE__, PL_reg_name[op], - (UV)(place - RExC_emit_start) > RExC_offsets[0] + (UV)(place - RExC_emit_start) > RExC_offsets[0] ? "Overwriting end of array!\n" : "OK", (UV)(place - RExC_emit_start), (UV)(RExC_parse - RExC_start), @@ -14835,7 +15135,7 @@ S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth) Set_Node_Offset(place, RExC_parse); Set_Node_Length(place, 1); } -#endif +#endif src = NEXTOPER(place); FILL_ADVANCE_NODE(place, op); Zero(src, offset, regnode); @@ -14847,7 +15147,8 @@ S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth) */ /* TODO: All three parms should be const */ STATIC void -S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth) +S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, + const regnode *val,U32 depth) { dVAR; regnode *scan; @@ -14894,7 +15195,7 @@ S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 de - Look for optimizable sequences at the same time. - currently only looks for EXACT chains. -This is experimental code. The idea is to use this routine to perform +This is experimental code. The idea is to use this routine to perform in place optimizations on branches and groups as they are constructed, with the long term intention of removing optimization from study_chunk so that it is purely analytical. @@ -14906,7 +15207,8 @@ to control which is which. /* TODO: All four parms should be const */ STATIC U8 -S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth) +S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, + const regnode *val,U32 depth) { dVAR; regnode *scan; @@ -14929,8 +15231,9 @@ S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val, regnode * const temp = regnext(scan); #ifdef EXPERIMENTAL_INPLACESCAN if (PL_regkind[OP(scan)] == EXACT) { - bool has_exactf_sharp_s; /* Unexamined in this routine */ - if (join_exact(pRExC_state,scan,&min, &has_exactf_sharp_s, 1,val,depth+1)) + bool unfolded_multi_char; /* Unexamined in this routine */ + if (join_exact(pRExC_state, scan, &min, + &unfolded_multi_char, 1, val, depth+1)) return EXACT; } #endif @@ -14970,7 +15273,8 @@ S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val, SV * const mysv_val=sv_newmortal(); DEBUG_PARSE_MSG(""); regprop(RExC_rx, mysv_val, val); - PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n", + PerlIO_printf(Perl_debug_log, + "~ attach to %s (%"IVdf") offset to %"IVdf"\n", SvPV_nolen_const(mysv_val), (IV)REG_NODE_NUM(val), (IV)(val - scan) @@ -15013,7 +15317,7 @@ S_regdump_intflags(pTHX_ const char *lead, const U32 flags) } } -static void +static void S_regdump_extflags(pTHX_ const char *lead, const U32 flags) { int bit; @@ -15025,11 +15329,11 @@ S_regdump_extflags(pTHX_ const char *lead, const U32 flags) if ((1<anchored_substr) { - RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr), + RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr), RE_SV_DUMPLEN(r->anchored_substr), 30); PerlIO_printf(Perl_debug_log, "anchored %s%s at %"IVdf" ", s, RE_SV_TAIL(r->anchored_substr), (IV)r->anchored_offset); } else if (r->anchored_utf8) { - RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8), + RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8), RE_SV_DUMPLEN(r->anchored_utf8), 30); PerlIO_printf(Perl_debug_log, "anchored utf8 %s%s at %"IVdf" ", s, RE_SV_TAIL(r->anchored_utf8), (IV)r->anchored_offset); - } + } if (r->float_substr) { - RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr), + RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr), RE_SV_DUMPLEN(r->float_substr), 30); PerlIO_printf(Perl_debug_log, "floating %s%s at %"IVdf"..%"UVuf" ", s, RE_SV_TAIL(r->float_substr), (IV)r->float_min_offset, (UV)r->float_max_offset); } else if (r->float_utf8) { - RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8), + RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8), RE_SV_DUMPLEN(r->float_utf8), 30); PerlIO_printf(Perl_debug_log, "floating utf8 %s%s at %"IVdf"..%"UVuf" ", @@ -15112,7 +15416,7 @@ Perl_regdump(pTHX_ const regexp *r) (r->check_substr == r->float_substr && r->check_utf8 == r->float_utf8 ? "(checking floating" : "(checking anchored")); - if (r->extflags & RXf_NOSCAN) + if (r->intflags & PREGf_NOSCAN) PerlIO_printf(Perl_debug_log, " noscan"); if (r->extflags & RXf_CHECK_ALL) PerlIO_printf(Perl_debug_log, " isall"); @@ -15123,19 +15427,19 @@ Perl_regdump(pTHX_ const regexp *r) regprop(r, sv, ri->regstclass); PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv)); } - if (r->extflags & RXf_ANCH) { + if (r->intflags & PREGf_ANCH) { PerlIO_printf(Perl_debug_log, "anchored"); - if (r->extflags & RXf_ANCH_BOL) + if (r->intflags & PREGf_ANCH_BOL) PerlIO_printf(Perl_debug_log, "(BOL)"); - if (r->extflags & RXf_ANCH_MBOL) + if (r->intflags & PREGf_ANCH_MBOL) PerlIO_printf(Perl_debug_log, "(MBOL)"); - if (r->extflags & RXf_ANCH_SBOL) + if (r->intflags & PREGf_ANCH_SBOL) PerlIO_printf(Perl_debug_log, "(SBOL)"); - if (r->extflags & RXf_ANCH_GPOS) + if (r->intflags & PREGf_ANCH_GPOS) PerlIO_printf(Perl_debug_log, "(GPOS)"); PerlIO_putc(Perl_debug_log, ' '); } - if (r->extflags & RXf_GPOS_SEEN) + if (r->intflags & PREGf_GPOS_SEEN) PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs); if (r->intflags & PREGf_SKIP) PerlIO_printf(Perl_debug_log, "plus "); @@ -15214,7 +15518,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) }; RXi_GET_DECL(prog,progi); GET_RE_DEBUG_FLAGS_DECL; - + PERL_ARGS_ASSERT_REGPROP; sv_setpvs(sv, ""); @@ -15222,16 +15526,17 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) if (OP(o) > REGNODE_MAX) /* regnode.type is unsigned */ /* It would be nice to FAIL() here, but this may be called from regexec.c, and it would be hard to supply pRExC_state. */ - Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX); + Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", + (int)OP(o), (int)REGNODE_MAX); sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */ k = PL_regkind[OP(o)]; if (k == EXACT) { sv_catpvs(sv, " "); - /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) - * is a crude hack but it may be the best for now since - * we have no flag "this EXACTish node was UTF-8" + /* 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), 60, PL_colors[0], PL_colors[1], PERL_PV_ESCAPE_UNI_DETECT | @@ -15250,19 +15555,19 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) NULL; const reg_trie_data * const trie = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie]; - + Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]); DEBUG_TRIE_COMPILE_r( - Perl_sv_catpvf(aTHX_ sv, - "", - (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 - ) + Perl_sv_catpvf(aTHX_ sv, + "", + (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, "["); @@ -15270,8 +15575,8 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) ? ANYOF_BITMAP(o) : TRIE_BITMAP(trie)); sv_catpvs(sv, "]"); - } - + } + } else if (k == CURLY) { if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX) Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */ @@ -15279,7 +15584,9 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) } else if (k == WHILEM && o->flags) /* Ordinal/of */ Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4); - else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) { + else if (k == REF || k == OPEN || k == CLOSE + || k == GROUPP || OP(o)==ACCEPT) + { Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */ if ( RXp_PAREN_NAMES(prog) ) { if ( k != REF || (OP(o) < NREF)) { @@ -15287,7 +15594,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) SV **name= av_fetch(list, ARG(o), 0 ); if (name) Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name)); - } + } else { AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]); SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]); @@ -15302,15 +15609,17 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name)); } } - } - } else if (k == GOSUB) - Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */ + } + } else if (k == GOSUB) + /* Paren and offset */ + Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); else if (k == VERB) { - if (!o->flags) - Perl_sv_catpvf(aTHX_ sv, ":%"SVf, + if (!o->flags) + Perl_sv_catpvf(aTHX_ sv, ":%"SVf, SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ])))); } else if (k == LOGICAL) - Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */ + /* 2: embedded, otherwise 1 */ + Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); else if (k == ANYOF) { const U8 flags = ANYOF_FLAGS(o); int do_sep = 0; @@ -15326,7 +15635,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) /* output what the standard cp 0-255 bitmap matches */ do_sep = put_latin1_charclass_innards(sv, ANYOF_BITMAP(o)); - + /* output any special charclass tests (used entirely under use * locale) * */ if (ANYOF_POSIXL_TEST_ANY_SET(o)) { @@ -15338,9 +15647,9 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) } } } - - if (flags & (ANYOF_ABOVE_LATIN1_ALL|ANYOF_ABOVE_LATIN1_ALL) - || ANYOF_NONBITMAP(o)) + + if ((flags & ANYOF_ABOVE_LATIN1_ALL) + || ANYOF_UTF8_LOCALE_INVLIST(o) || ANYOF_NONBITMAP(o)) { if (do_sep) { Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]); @@ -15348,72 +15657,91 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) /*make sure the invert info is in each */ sv_catpvs(sv, "^"); } - - if (flags & ANYOF_NON_UTF8_LATIN1_ALL) { - sv_catpvs(sv, "{non-utf8-latin1-all}"); - } - - /* output information about the unicode matching */ - if (flags & ANYOF_ABOVE_LATIN1_ALL) - sv_catpvs(sv, "{unicode_all}"); - else if (ANYOF_NONBITMAP(o)) { - SV *lv; /* Set if there is something outside the bit map. */ - bool byte_output = FALSE; /* If something in the bitmap has been - output */ - if (flags & ANYOF_NONBITMAP_NON_UTF8) { - sv_catpvs(sv, "{outside bitmap}"); - } - else { - sv_catpvs(sv, "{utf8}"); + if (OP(o) == ANYOF_NON_UTF8_NON_ASCII_ALL) { + sv_catpvs(sv, "{non-utf8-latin1-all}"); } - /* Get the stuff that wasn't in the bitmap */ - (void) regclass_swash(prog, o, FALSE, &lv, NULL); - if (lv && lv != &PL_sv_undef) { - char *s = savesvpv(lv); - char * const origs = s; + /* output information about the unicode matching */ + if (flags & ANYOF_ABOVE_LATIN1_ALL) + sv_catpvs(sv, "{unicode_all}"); + else if (ANYOF_NONBITMAP(o)) { + SV *lv; /* Set if there is something outside the bit map. */ + bool byte_output = FALSE; /* If something in the bitmap has + been output */ + + /* Get the stuff that wasn't in the bitmap */ + (void) regclass_swash(prog, o, FALSE, &lv, NULL); + if (lv && lv != &PL_sv_undef) { + char *s = savesvpv(lv); + char * const origs = s; + + while (*s && *s != '\n') + s++; - while (*s && *s != '\n') - s++; + if (*s == '\n') { + const char * const t = ++s; - if (*s == '\n') { - const char * const t = ++s; + if (flags & ANYOF_NONBITMAP_NON_UTF8) { + sv_catpvs(sv, "{outside bitmap}"); + } + else { + sv_catpvs(sv, "{utf8}"); + } - if (byte_output) { - sv_catpvs(sv, " "); - } + if (byte_output) { + sv_catpvs(sv, " "); + } - while (*s) { - if (*s == '\n') { + while (*s) { + if (*s == '\n') { - /* Truncate very long output */ - if (s - origs > 256) { - Perl_sv_catpvf(aTHX_ sv, - "%.*s...", - (int) (s - origs - 1), - t); - goto out_dump; + /* Truncate very long output */ + if (s - origs > 256) { + Perl_sv_catpvf(aTHX_ sv, + "%.*s...", + (int) (s - origs - 1), + t); + goto out_dump; + } + *s = ' '; } - *s = ' '; - } - else if (*s == '\t') { - *s = '-'; + else if (*s == '\t') { + *s = '-'; + } + s++; } - s++; + if (s[-1] == ' ') + s[-1] = 0; + + sv_catpv(sv, t); } - if (s[-1] == ' ') - s[-1] = 0; - sv_catpv(sv, t); - } + out_dump: - out_dump: + Safefree(origs); + SvREFCNT_dec_NN(lv); + } + } - Safefree(origs); - SvREFCNT_dec_NN(lv); - } - } + /* Output any UTF-8 locale code points */ + if (flags & ANYOF_LOC_FOLD && ANYOF_UTF8_LOCALE_INVLIST(o)) { + UV start, end; + int max_entries = 256; + + sv_catpvs(sv, "{utf8 locale}"); + invlist_iterinit(ANYOF_UTF8_LOCALE_INVLIST(o)); + while (invlist_iternext(ANYOF_UTF8_LOCALE_INVLIST(o), + &start, &end)) { + put_range(sv, start, end); + max_entries --; + if (max_entries < 0) { + sv_catpvs(sv, "..."); + break; + } + } + invlist_iterfinish(ANYOF_UTF8_LOCALE_INVLIST(o)); + } } Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]); @@ -15472,17 +15800,17 @@ Perl_re_intuit_string(pTHX_ REGEXP * const r) return prog->check_substr ? prog->check_substr : prog->check_utf8; } -/* - pregfree() - - handles refcounting and freeing the perl core regexp structure. When - it is necessary to actually free the structure the first thing it +/* + pregfree() + + handles refcounting and freeing the perl core regexp structure. When + it is necessary to actually free the structure the first thing it does is call the 'free' method of the regexp_engine associated to - the regexp, allowing the handling of the void *pprivate; member - first. (This routine is not overridable by extensions, which is why + the regexp, allowing the handling of the void *pprivate; member + first. (This routine is not overridable by extensions, which is why the extensions free is called first.) - - See regdupe and regdupe_internal if you change anything here. + + See regdupe and regdupe_internal if you change anything here. */ #ifndef PERL_IN_XSUB_RE void @@ -15506,7 +15834,7 @@ Perl_pregfree2(pTHX_ REGEXP *rx) CALLREGFREE_PVT(rx); /* free the private data */ SvREFCNT_dec(RXp_PAREN_NAMES(r)); Safefree(r->xpv_len_u.xpvlenu_pv); - } + } if (r->substrs) { SvREFCNT_dec(r->anchored_substr); SvREFCNT_dec(r->anchored_utf8); @@ -15524,22 +15852,22 @@ Perl_pregfree2(pTHX_ REGEXP *rx) } /* reg_temp_copy() - + This is a hacky workaround to the structural issue of match results being stored in the regexp structure which is in turn stored in PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern could be PL_curpm in multiple contexts, and could require multiple result sets being associated with the pattern simultaneously, such as when doing a recursive match with (??{$qr}) - - The solution is to make a lightweight copy of the regexp structure + + The solution is to make a lightweight copy of the regexp structure when a qr// is returned from the code executed by (??{$qr}) this lightweight copy doesn't actually own any of its data except for - the starp/end and the actual regexp structure itself. - -*/ - - + the starp/end and the actual regexp structure itself. + +*/ + + REGEXP * Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx) { @@ -15572,7 +15900,7 @@ Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx) sv_force_normal(sv) is called. */ SvFAKE_on(ret_x); ret = ReANY(ret_x); - + SvFLAGS(ret_x) |= SvUTF8(rx); /* We share the same string buffer as the original regexp, on which we hold a reference count, incremented when mother_re is set below. @@ -15603,23 +15931,23 @@ Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx) #endif ret->mother_re = ReREFCNT_inc(r->mother_re ? r->mother_re : rx); SvREFCNT_inc_void(ret->qr_anoncv); - + return ret_x; } #endif -/* regfree_internal() +/* regfree_internal() - Free the private data in a regexp. This is overloadable by - extensions. Perl takes care of the regexp structure in pregfree(), - this covers the *pprivate pointer which technically perl doesn't - know about, however of course we have to handle the - regexp_internal structure when no extension is in use. - - Note this is called before freeing anything in the regexp - structure. + Free the private data in a regexp. This is overloadable by + extensions. Perl takes care of the regexp structure in pregfree(), + this covers the *pprivate pointer which technically perl doesn't + know about, however of course we have to handle the + regexp_internal structure when no extension is in use. + + Note this is called before freeing anything in the regexp + structure. */ - + void Perl_regfree_internal(pTHX_ REGEXP * const rx) { @@ -15637,7 +15965,7 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx) SV *dsv= sv_newmortal(); RE_PV_QUOTED_DECL(s, RX_UTF8(rx), dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60); - PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", + PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", PL_colors[4],PL_colors[5],s); } }); @@ -15671,7 +15999,7 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx) case 'l': case 'L': break; - case 'T': + case 'T': { /* Aho Corasick add-on structure for a trie node. Used in stclass optimization only */ U32 refcount; @@ -15711,7 +16039,8 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx) } break; default: - Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]); + Perl_croak(aTHX_ "panic: regfree data code '%c'", + ri->data->what[n]); } } Safefree(ri->data->what); @@ -15725,9 +16054,9 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx) #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t)) #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL) -/* - re_dup - duplicate a regexp. - +/* + re_dup - duplicate a regexp. + This routine is expected to clone a given regexp structure. It is only compiled under USE_ITHREADS. @@ -15736,7 +16065,7 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx) stored in the *pprivate pointer. This allows extensions to handle any duplication it needs to do. - See pregfree() and regfree_internal() if you change anything here. + See pregfree() and regfree_internal() if you change anything here. */ #if defined(USE_ITHREADS) #ifndef PERL_IN_XSUB_RE @@ -15747,7 +16076,7 @@ Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param) I32 npar; const struct regexp *r = ReANY(sstr); struct regexp *ret = ReANY(dstr); - + PERL_ARGS_ASSERT_RE_DUP_GUTS; npar = r->nparens+1; @@ -15819,15 +16148,15 @@ Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param) /* regdupe_internal() - + This is the internal complement to regdupe() which is used to copy the structure pointed to by the *pprivate pointer in the regexp. This is the core version of the extension overridable cloning hook. The regexp structure being duplicated will be copied by perl prior - to this and will be provided as the regexp *r argument, however + to this and will be provided as the regexp *r argument, however with the /old/ structures pprivate pointer value. Thus this routine may override any copying normally done by perl. - + It returns a pointer to the new regexp_internal structure. */ @@ -15841,10 +16170,11 @@ Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param) RXi_GET_DECL(r,ri); PERL_ARGS_ASSERT_REGDUPE_INTERNAL; - + len = ProgLen(ri); - - Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal); + + Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), + char, regexp_internal); Copy(ri->program, reti->program, len+1, regnode); reti->num_code_blocks = ri->num_code_blocks; @@ -15907,7 +16237,8 @@ Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param) d->data[i] = ri->data->data[i]; break; default: - Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]); + Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", + ri->data->what[i]); } } @@ -15947,7 +16278,8 @@ Perl_regnext(pTHX_ regnode *p) return(NULL); if (OP(p) > REGNODE_MAX) { /* regnode.type is unsigned */ - Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX); + Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", + (int)OP(p), (int)REGNODE_MAX); } offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p)); @@ -16004,7 +16336,8 @@ Perl_save_re_context(pTHX) U32 i; for (i = 1; i <= RX_NPARENS(rx); i++) { char digits[TYPE_CHARS(long)]; - const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i); + const STRLEN len = my_snprintf(digits, sizeof(digits), + "%lu", (long)i); GV *const *const gvp = (GV**)hv_fetch(PL_defstash, digits, len, 0); @@ -16026,19 +16359,6 @@ S_put_byte(pTHX_ SV *sv, int c) { PERL_ARGS_ASSERT_PUT_BYTE; - /* Our definition of isPRINT() ignores locales, so only bytes that are - not part of UTF-8 are considered printable. I assume that the same - holds for UTF-EBCDIC. - Also, code point 255 is not printable in either (it's E0 in EBCDIC, - which Wikipedia says: - - EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all - ones (binary 1111 1111, hexadecimal FF). It is similar, but not - identical, to the ASCII delete (DEL) or rubout control character. ... - it is typically mapped to hexadecimal code 9F, in order to provide a - unique character mapping in both directions) - - So the old condition can be simplified to !isPRINT(c) */ if (!isPRINT(c)) { switch (c) { case '\r': Perl_sv_catpvf(aTHX_ sv, "\\r"); break; @@ -16060,6 +16380,48 @@ S_put_byte(pTHX_ SV *sv, int c) } } +STATIC void +S_put_range(pTHX_ SV *sv, UV start, UV end) +{ + + /* Appends to 'sv' a displayable version of the range of code points from + * 'start' to 'end' */ + + assert(start <= end); + + PERL_ARGS_ASSERT_PUT_RANGE; + + if (end - start < 3) { /* Individual chars in short ranges */ + for (; start <= end; start++) + put_byte(sv, start); + } + else if ( end > 255 + || ! isALPHANUMERIC(start) + || ! isALPHANUMERIC(end) + || isDIGIT(start) != isDIGIT(end) + || isUPPER(start) != isUPPER(end) + || isLOWER(start) != isLOWER(end) + + /* This final test should get optimized out except on EBCDIC + * platforms, where it causes ranges that cross discontinuities + * like i/j to be shown as hex instead of the misleading, + * e.g. H-K (since that range includes more than H, I, J, K). + * */ + || (end - start) != NATIVE_TO_ASCII(end) - NATIVE_TO_ASCII(start)) + { + Perl_sv_catpvf(aTHX_ sv, "\\x{%02" UVXf "}-\\x{%02" UVXf "}", + start, + (end < 256) ? end : 255); + } + else { /* Here, the ends of the range are both digits, or both uppercase, + or both lowercase; and there's no discontinuity in the range + (which could happen on EBCDIC platforms) */ + put_byte(sv, start); + sv_catpvs(sv, "-"); + put_byte(sv, end); + } +} + STATIC bool S_put_latin1_charclass_innards(pTHX_ SV *sv, char *bitmap) { @@ -16068,50 +16430,27 @@ S_put_latin1_charclass_innards(pTHX_ SV *sv, char *bitmap) * output anything */ int i; - int rangestart = -1; bool has_output_anything = FALSE; PERL_ARGS_ASSERT_PUT_LATIN1_CHARCLASS_INNARDS; - for (i = 0; i <= 256; i++) { + for (i = 0; i < 256; i++) { if (i < 256 && BITMAP_TEST((U8 *) bitmap,i)) { - if (rangestart == -1) - rangestart = i; - } else if (rangestart != -1) { - int j = i - 1; - if (i <= rangestart + 3) { /* Individual chars in short ranges */ - for (; rangestart < i; rangestart++) - put_byte(sv, rangestart); - } - else if ( j > 255 - || ! isALPHANUMERIC(rangestart) - || ! isALPHANUMERIC(j) - || isDIGIT(rangestart) != isDIGIT(j) - || isUPPER(rangestart) != isUPPER(j) - || isLOWER(rangestart) != isLOWER(j) - - /* This final test should get optimized out except - * on EBCDIC platforms, where it causes ranges that - * cross discontinuities like i/j to be shown as hex - * instead of the misleading, e.g. H-K (since that - * range includes more than H, I, J, K). */ - || (j - rangestart) - != NATIVE_TO_ASCII(j) - NATIVE_TO_ASCII(rangestart)) - { - Perl_sv_catpvf(aTHX_ sv, "\\x{%02x}-\\x{%02x}", - rangestart, - (j < 256) ? j : 255); - } - else { /* Here, the ends of the range are both digits, or both - uppercase, or both lowercase; and there's no - discontinuity in the range (which could happen on EBCDIC - platforms) */ - put_byte(sv, rangestart); - sv_catpvs(sv, "-"); - put_byte(sv, j); - } - rangestart = -1; + + /* The character at index i should be output. Find the next + * character that should NOT be output */ + int j; + for (j = i + 1; j <= 256; j++) { + if (! BITMAP_TEST((U8 *) bitmap, j)) { + break; + } + } + + /* Everything between them is a single range that should be output + * */ + put_range(sv, i, j - 1); has_output_anything = TRUE; + i = j; } } @@ -16119,23 +16458,26 @@ S_put_latin1_charclass_innards(pTHX_ SV *sv, char *bitmap) } #define CLEAR_OPTSTART \ - if (optstart) STMT_START { \ - DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \ - optstart=NULL; \ + if (optstart) STMT_START { \ + DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, \ + " (%"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); +#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, + const regnode *last, const regnode *plast, SV* sv, I32 indent, U32 depth) { dVAR; U8 op = PSEUDO; /* Arbitrary non-END op. */ const regnode *next; const regnode *optstart= NULL; - + RXi_GET_DECL(r,ri); GET_RE_DEBUG_FLAGS_DECL; @@ -16145,8 +16487,8 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start, last ? last-start : 0,plast ? plast-start : 0); #endif - - if (plast && plast < last) + + if (plast && plast < last) last= plast; while (PL_regkind[op] != END && (!last || node < last)) { @@ -16169,17 +16511,18 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, regprop(r, sv, node); PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start), (int)(2*indent + 1), "", SvPVX_const(sv)); - - if (OP(node) != OPTIMIZED) { + + if (OP(node) != OPTIMIZED) { if (next == NULL) /* Next ptr. */ PerlIO_printf(Perl_debug_log, " (0)"); - else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH ) + else if (PL_regkind[(U8)op] == BRANCH + && PL_regkind[OP(next)] != BRANCH ) PerlIO_printf(Perl_debug_log, " (FAIL)"); - else + else PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start)); - (void)PerlIO_putc(Perl_debug_log, '\n'); + (void)PerlIO_putc(Perl_debug_log, '\n'); } - + after_print: if (PL_regkind[(U8)op] == BRANCHJ) { assert(next); @@ -16206,7 +16549,8 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, const reg_trie_data * const trie = (reg_trie_data*)ri->data->data[optrie]; #ifdef DEBUGGING - AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]); + AV *const trie_words + = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]); #endif const regnode *nextbranch= NULL; I32 word_idx; @@ -16216,21 +16560,25 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, PerlIO_printf(Perl_debug_log, "%*s%s ", (int)(2*(indent+3)), "", - elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60, - PL_colors[0], PL_colors[1], - (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) | - PERL_PV_PRETTY_ELLIPSES | - PERL_PV_PRETTY_LTGT + elem_ptr + ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), + SvCUR(*elem_ptr), 60, + 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]; PerlIO_printf(Perl_debug_log, "(%"UVuf")\n", - (UV)((dist ? this_trie + dist : next) - start)); + (UV)((dist ? this_trie + dist : next) - start)); if (dist) { if (!nextbranch) - nextbranch= this_trie + trie->jump[0]; + nextbranch= this_trie + trie->jump[0]; DUMPUNTIL(this_trie + dist, nextbranch); } if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH) @@ -16257,8 +16605,11 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, } else if (PL_regkind[(U8)op] == ANYOF) { /* arglen 1 + class block */ - node += 1 + ((ANYOF_FLAGS(node) & ANYOF_POSIXL) - ? ANYOF_POSIXL_SKIP : ANYOF_SKIP); + node += 1 + ((ANYOF_FLAGS(node) & ANYOF_LOC_FOLD) + ? ANYOF_POSIXL_FOLD_SKIP + : (ANYOF_FLAGS(node) & ANYOF_POSIXL) + ? ANYOF_POSIXL_SKIP + : ANYOF_SKIP); node = NEXTOPER(node); } else if (PL_regkind[(U8)op] == EXACT) { @@ -16274,7 +16625,7 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, indent++; } CLEAR_OPTSTART; -#ifdef DEBUG_DUMPUNTIL +#ifdef DEBUG_DUMPUNTIL PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent); #endif return node;