X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/68f986b99c71413001891e9dff012b525d6d6d78..dc456155af24d5c772439d33c322bd72cb0fcdfe:/regcomp.c diff --git a/regcomp.c b/regcomp.c index d03fe3e..70e9e2f 100644 --- a/regcomp.c +++ b/regcomp.c @@ -142,6 +142,8 @@ typedef struct RExC_state_t { regnode **recurse; /* Recurse regops */ I32 recurse_count; /* Number of recurse regops */ I32 in_lookbehind; + I32 contains_locale; + I32 override_recoding; #if ADD_TO_REGEXEC char *starttry; /* -Dr: where regtry was called. */ #define RExC_starttry (pRExC_state->starttry) @@ -190,6 +192,8 @@ typedef struct RExC_state_t { #define RExC_recurse (pRExC_state->recurse) #define RExC_recurse_count (pRExC_state->recurse_count) #define RExC_in_lookbehind (pRExC_state->in_lookbehind) +#define RExC_contains_locale (pRExC_state->contains_locale) +#define RExC_override_recoding (pRExC_state->override_recoding) #define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?') @@ -720,16 +724,28 @@ S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *min /* Can match anything (initialization) */ STATIC void -S_cl_anything(struct regnode_charclass_class *cl) +S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl) { PERL_ARGS_ASSERT_CL_ANYTHING; ANYOF_BITMAP_SETALL(cl); - ANYOF_CLASS_ZERO(cl); /* all bits set, so class is irrelevant */ - cl->flags = ANYOF_EOS|ANYOF_UNICODE_ALL|ANYOF_LOC_NONBITMAP_FOLD|ANYOF_NON_UTF8_LATIN1_ALL|ANYOF_LOCALE; - /* The above line set locale which given the current logic may not get - * cleared even if no locale is in the regex, which may lead to false - * positives; see the commit message */ + cl->flags = ANYOF_CLASS|ANYOF_EOS|ANYOF_UNICODE_ALL + |ANYOF_LOC_NONBITMAP_FOLD|ANYOF_NON_UTF8_LATIN1_ALL; + + /* If any portion of the regex is to operate under locale rules, + * initialization includes it. The reason this isn't done for all regexes + * is that the optimizer was written under the assumption that locale was + * all-or-nothing. Given the complexity and lack of documentation in the + * optimizer, and that there are inadequate test cases for locale, so many + * parts of it may not work properly, it is safest to avoid locale unless + * necessary. */ + if (RExC_contains_locale) { + ANYOF_CLASS_SETALL(cl); /* /l uses class */ + cl->flags |= ANYOF_LOCALE; + } + else { + ANYOF_CLASS_ZERO(cl); /* Only /l uses class now */ + } } /* Can match anything (initialization) */ @@ -752,21 +768,22 @@ S_cl_is_anything(const struct regnode_charclass_class *cl) /* Can match anything (initialization) */ STATIC void -S_cl_init(struct regnode_charclass_class *cl) +S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl) { PERL_ARGS_ASSERT_CL_INIT; Zero(cl, 1, struct regnode_charclass_class); cl->type = ANYOF; - cl_anything(cl); + cl_anything(pRExC_state, cl); ARG_SET(cl, ANYOF_NONBITMAP_EMPTY); } /* These two functions currently do the exact same thing */ #define cl_init_zero S_cl_init -/* 'And' a given class with another one. Can create false positives */ -/* cl should not be inverted */ +/* 'AND' a given class with another one. Can create false positives. 'cl' + * should not be inverted. 'and_with->flags & ANYOF_CLASS' should be 0 if + * 'and_with' is a regnode_charclass instead of a regnode_charclass_class. */ STATIC void S_cl_and(struct regnode_charclass_class *cl, const struct regnode_charclass_class *and_with) @@ -816,6 +833,8 @@ S_cl_and(struct regnode_charclass_class *cl, } } else { /* and'd node is not inverted */ + U8 outside_bitmap_but_not_utf8; /* Temp variable */ + if (! ANYOF_NONBITMAP(and_with)) { /* Here 'and_with' doesn't match anything outside the bitmap @@ -834,14 +853,18 @@ S_cl_and(struct regnode_charclass_class *cl, /* Here, 'and_with' does match something outside the bitmap, and cl * doesn't have a list of things to match outside the bitmap. If * cl can match all code points above 255, the intersection will - * be those above-255 code points that 'and_with' matches. There - * may be false positives from code points in 'and_with' that are - * outside the bitmap but below 256, but those get sorted out - * after the synthetic start class succeeds). If cl can't match - * all Unicode code points, it means here that it can't match * - * anything outside the bitmap, so we leave the bitmap empty */ + * be those above-255 code points that 'and_with' matches. If cl + * can't match all Unicode code points, it means that it can't + * match anything outside the bitmap (since the 'if' that got us + * into this block tested for that), so we leave the bitmap empty. + */ if (cl->flags & ANYOF_UNICODE_ALL) { ARG_SET(cl, ARG(and_with)); + + /* and_with's ARG may match things that don't require UTF8. + * And now cl's will too, in spite of this being an 'and'. See + * the comments below about the kludge */ + cl->flags |= and_with->flags & ANYOF_NONBITMAP_NON_UTF8; } } else { @@ -851,15 +874,41 @@ S_cl_and(struct regnode_charclass_class *cl, } - /* Take the intersection of the two sets of flags */ + /* Take the intersection of the two sets of flags. However, the + * ANYOF_NONBITMAP_NON_UTF8 flag is treated as an 'or'. This is a + * kludge around the fact that this flag is not treated like the others + * which are initialized in cl_anything(). The way the optimizer works + * is that the synthetic start class (SSC) is initialized to match + * anything, and then the first time a real node is encountered, its + * values are AND'd with the SSC's with the result being the values of + * the real node. However, there are paths through the optimizer where + * the AND never gets called, so those initialized bits are set + * inappropriately, which is not usually a big deal, as they just cause + * false positives in the SSC, which will just mean a probably + * imperceptible slow down in execution. However this bit has a + * higher false positive consequence in that it can cause utf8.pm, + * utf8_heavy.pl ... to be loaded when not necessary, which is a much + * bigger slowdown and also causes significant extra memory to be used. + * In order to prevent this, the code now takes a different tack. The + * bit isn't set unless some part of the regular expression needs it, + * but once set it won't get cleared. This means that these extra + * modules won't get loaded unless there was some path through the + * pattern that would have required them anyway, and so any false + * positives that occur by not ANDing them out when they could be + * aren't as severe as they would be if we treated this bit like all + * the others */ + outside_bitmap_but_not_utf8 = (cl->flags | and_with->flags) + & ANYOF_NONBITMAP_NON_UTF8; cl->flags &= and_with->flags; + cl->flags |= outside_bitmap_but_not_utf8; } } -/* 'OR' a given class with another one. Can create false positives */ -/* cl should not be inverted */ +/* 'OR' a given class with another one. Can create false positives. 'cl' + * should not be inverted. 'or_with->flags & ANYOF_CLASS' should be 0 if + * 'or_with' is a regnode_charclass instead of a regnode_charclass_class. */ STATIC void -S_cl_or(struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with) +S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with) { PERL_ARGS_ASSERT_CL_OR; @@ -869,7 +918,7 @@ S_cl_or(struct regnode_charclass_class *cl, const struct regnode_charclass_class * complement of everything not in the bitmap, but currently we don't * know what that is, so give up and match anything */ if (ANYOF_NONBITMAP(or_with)) { - cl_anything(cl); + cl_anything(pRExC_state, cl); } /* We do not use * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2)) @@ -889,7 +938,7 @@ S_cl_or(struct regnode_charclass_class *cl, const struct regnode_charclass_class cl->bitmap[i] |= ~or_with->bitmap[i]; } /* XXXX: logic is complicated otherwise */ else { - cl_anything(cl); + cl_anything(pRExC_state, cl); } /* And, we can just take the union of the flags that aren't affected @@ -922,12 +971,9 @@ S_cl_or(struct regnode_charclass_class *cl, const struct regnode_charclass_class } } else { /* XXXX: logic is complicated, leave it along for a moment. */ - cl_anything(cl); + cl_anything(pRExC_state, cl); } - /* Take the union */ - cl->flags |= or_with->flags; - if (ANYOF_NONBITMAP(or_with)) { /* Use the added node's outside-the-bit-map match if there isn't a @@ -935,14 +981,24 @@ S_cl_or(struct regnode_charclass_class *cl, const struct regnode_charclass_class * outside the bitmap, but what they match outside is not the same * pointer, and hence not easily compared until XXX we extend * inversion lists this far), give up and allow the start class to - * match everything outside the bitmap */ + * match everything outside the bitmap. If that stuff is all above + * 255, can just set UNICODE_ALL, otherwise caould be anything. */ if (! ANYOF_NONBITMAP(cl)) { ARG_SET(cl, ARG(or_with)); } else if (ARG(cl) != ARG(or_with)) { - cl->flags |= ANYOF_UNICODE_ALL; + + if ((or_with->flags & ANYOF_NONBITMAP_NON_UTF8)) { + cl_anything(pRExC_state, cl); + } + else { + cl->flags |= ANYOF_UNICODE_ALL; + } } } + + /* Take the union */ + cl->flags |= or_with->flags; } } @@ -1331,8 +1387,8 @@ is the recommended Unicode-aware way of saying scan += len; \ len = 0; \ } else { \ - uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\ - uvc = to_uni_fold( uvc, foldbuf, &foldlen ); \ + len = UTF8SKIP(uc);\ + uvc = to_utf8_fold( uc, foldbuf, &foldlen); \ foldlen -= UNISKIP( uvc ); \ scan = foldbuf + UNISKIP( uvc ); \ } \ @@ -2591,13 +2647,13 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags } #ifdef DEBUGGING - /* Allow dumping */ + /* Allow dumping but overwriting the collection of skipped + * ops and/or strings with fake optimized ops */ n = scan + NODE_SZ_STR(scan); while (n <= stop) { - if (PL_regkind[OP(n)] != NOTHING || OP(n) == NOTHING) { - OP(n) = OPTIMIZED; - NEXT_OFF(n) = 0; - } + OP(n) = OPTIMIZED; + FLAGS(n) = 0; + NEXT_OFF(n) = 0; n++; } #endif @@ -2752,7 +2808,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if (flags & SCF_DO_SUBSTR) SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */ if (flags & SCF_DO_STCLASS) - cl_init_zero(&accum); + cl_init_zero(pRExC_state, &accum); while (OP(scan) == code) { I32 deltanext, minnext, f = 0, fake; @@ -2773,7 +2829,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if (code != BRANCH) scan = NEXTOPER(scan); if (flags & SCF_DO_STCLASS) { - cl_init(&this_class); + cl_init(pRExC_state, &this_class); data_fake.start_class = &this_class; f = SCF_DO_STCLASS_AND; } @@ -2806,7 +2862,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, data->whilem_c = data_fake.whilem_c; } if (flags & SCF_DO_STCLASS) - cl_or(&accum, &this_class); + cl_or(pRExC_state, &accum, &this_class); } if (code == IFTHEN && num < 2) /* Empty ELSE branch */ min1 = 0; @@ -2819,7 +2875,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, min += min1; delta += max1 - min1; if (flags & SCF_DO_STCLASS_OR) { - cl_or(data->start_class, &accum); + cl_or(pRExC_state, data->start_class, &accum); if (min1) { cl_and(data->start_class, and_withp); flags &= ~SCF_DO_STCLASS; @@ -2992,20 +3048,17 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } } else { /* - Currently we do not believe that the trie logic can - handle case insensitive matching properly when the - pattern is not unicode (thus forcing unicode semantics). + Currently the trie logic handles case insensitive matching properly only + when the pattern is UTF-8 and the node is EXACTFU (thus forcing unicode + semantics). If/when this is fixed the following define can be swapped in below to fully enable trie logic. - XXX It may work if not UTF and/or /a (AT_LEAST_UNI_SEMANTICS) but perhaps - not /aa - #define TRIE_TYPE_IS_SAFE 1 */ -#define TRIE_TYPE_IS_SAFE ((UTF && UNI_SEMANTICS) || optype==EXACT) +#define TRIE_TYPE_IS_SAFE ((UTF && optype == EXACTFU) || optype==EXACT) if ( last && TRIE_TYPE_IS_SAFE ) { make_trie( pRExC_state, @@ -3094,7 +3147,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } is_inf = is_inf_internal = 1; if (flags & SCF_DO_STCLASS_OR) /* Allow everything */ - cl_anything(data->start_class); + cl_anything(pRExC_state, data->start_class); flags &= ~SCF_DO_STCLASS; } } else { @@ -3358,7 +3411,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, data->flags |= SF_IS_INF; } if (flags & SCF_DO_STCLASS) { - cl_init(&this_class); + cl_init(pRExC_state, &this_class); oclass = data->start_class; data->start_class = &this_class; f |= SCF_DO_STCLASS_AND; @@ -3386,7 +3439,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, data->start_class = oclass; if (mincount == 0 || minnext == 0) { if (flags & SCF_DO_STCLASS_OR) { - cl_or(data->start_class, &this_class); + cl_or(pRExC_state, data->start_class, &this_class); } else if (flags & SCF_DO_STCLASS_AND) { /* Switch to OR mode: cache the old value of @@ -3402,7 +3455,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } } else { /* Non-zero len */ if (flags & SCF_DO_STCLASS_OR) { - cl_or(data->start_class, &this_class); + cl_or(pRExC_state, data->start_class, &this_class); cl_and(data->start_class, and_withp); } else if (flags & SCF_DO_STCLASS_AND) @@ -3652,7 +3705,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } is_inf = is_inf_internal = 1; if (flags & SCF_DO_STCLASS_OR) - cl_anything(data->start_class); + cl_anything(pRExC_state, data->start_class); flags &= ~SCF_DO_STCLASS; break; } @@ -3715,7 +3768,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, do_default: /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */ if (flags & SCF_DO_STCLASS_OR) /* Allow everything */ - cl_anything(data->start_class); + cl_anything(pRExC_state, data->start_class); break; case REG_ANY: if (OP(scan) == SANY) @@ -3723,7 +3776,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */ value = (ANYOF_BITMAP_TEST(data->start_class,'\n') || ANYOF_CLASS_TEST_ANY_SET(data->start_class)); - cl_anything(data->start_class); + cl_anything(pRExC_state, data->start_class); } if (flags & SCF_DO_STCLASS_AND || !value) ANYOF_BITMAP_CLEAR(data->start_class,'\n'); @@ -3733,7 +3786,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, cl_and(data->start_class, (struct regnode_charclass_class*)scan); else - cl_or(data->start_class, + cl_or(pRExC_state, data->start_class, (struct regnode_charclass_class*)scan); break; case ALNUM: @@ -3967,7 +4020,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, data_fake.pos_delta = delta; if ( flags & SCF_DO_STCLASS && !scan->flags && OP(scan) == IFMATCH ) { /* Lookahead */ - cl_init(&intrnl); + cl_init(pRExC_state, &intrnl); data_fake.start_class = &intrnl; f |= SCF_DO_STCLASS_AND; } @@ -4001,7 +4054,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, * *** HACK *** for now just treat as "no information". * See [perl #56690]. */ - cl_init(data->start_class); + cl_init(pRExC_state, data->start_class); } else { /* AND before and after: combine and continue */ const int was = (data->start_class->flags & ANYOF_EOS); @@ -4052,7 +4105,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, data_fake.flags |= SF_IS_INF; if ( flags & SCF_DO_STCLASS && !scan->flags && OP(scan) == IFMATCH ) { /* Lookahead */ - cl_init(&intrnl); + cl_init(pRExC_state, &intrnl); data_fake.start_class = &intrnl; f |= SCF_DO_STCLASS_AND; } @@ -4154,7 +4207,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } is_inf = is_inf_internal = 1; if (flags & SCF_DO_STCLASS_OR) /* Allow everything */ - cl_anything(data->start_class); + cl_anything(pRExC_state, data->start_class); flags &= ~SCF_DO_STCLASS; } else if (OP(scan) == GPOS) { @@ -4185,7 +4238,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */ SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */ if (flags & SCF_DO_STCLASS) - cl_init_zero(&accum); + cl_init_zero(pRExC_state, &accum); if (!trie->jump) { min1= trie->minlen; @@ -4208,7 +4261,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, data_fake.last_closep = &fake; data_fake.pos_delta = delta; if (flags & SCF_DO_STCLASS) { - cl_init(&this_class); + cl_init(pRExC_state, &this_class); data_fake.start_class = &this_class; f = SCF_DO_STCLASS_AND; } @@ -4252,7 +4305,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, data->whilem_c = data_fake.whilem_c; } if (flags & SCF_DO_STCLASS) - cl_or(&accum, &this_class); + cl_or(pRExC_state, &accum, &this_class); } } if (flags & SCF_DO_SUBSTR) { @@ -4264,7 +4317,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, min += min1; delta += max1 - min1; if (flags & SCF_DO_STCLASS_OR) { - cl_or(data->start_class, &accum); + cl_or(pRExC_state, data->start_class, &accum); if (min1) { cl_and(data->start_class, and_withp); flags &= ~SCF_DO_STCLASS; @@ -4470,7 +4523,7 @@ Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags) struct regexp *r; register regexp_internal *ri; STRLEN plen; - char *exp; + char* VOL exp; char* xend; regnode *scan; I32 flags; @@ -4483,6 +4536,7 @@ Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags) I32 sawplus = 0; I32 sawopen = 0; bool used_setjump = FALSE; + regex_charset initial_charset = get_regex_charset(orig_pm_flags); U8 jump_ret = 0; dJMPENV; @@ -4499,8 +4553,16 @@ Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags) DEBUG_r(if (!PL_colorset) reginitcolors()); - RExC_utf8 = RExC_orig_utf8 = SvUTF8(pattern); + exp = SvPV(pattern, plen); + + if (plen == 0) { /* ignore the utf8ness if the pattern is 0 length */ + RExC_utf8 = RExC_orig_utf8 = 0; + } + else { + RExC_utf8 = RExC_orig_utf8 = SvUTF8(pattern); + } RExC_uni_semantics = 0; + RExC_contains_locale = 0; /****************** LONG JUMP TARGET HERE***********************/ /* Longjmp back to here if have to switch in midstream to utf8 */ @@ -4510,12 +4572,7 @@ Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags) } if (jump_ret == 0) { /* First time through */ - exp = SvPV(pattern, plen); xend = exp + plen; - /* ignore the utf8ness if the pattern is 0 length */ - if (plen == 0) { - RExC_utf8 = RExC_orig_utf8 = 0; - } DEBUG_COMPILE_r({ SV *dsv= sv_newmortal(); @@ -4547,7 +4604,9 @@ Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags) -- dmq */ DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "UTF8 mismatch! Converting to utf8 for resizing and compile\n")); - exp = (char*)Perl_bytes_to_utf8(aTHX_ (U8*)SvPV(pattern, plen), &len); + exp = (char*)Perl_bytes_to_utf8(aTHX_ + (U8*)SvPV_nomg(pattern, plen), + &len); xend = exp + len; RExC_orig_utf8 = RExC_utf8 = 1; SAVEFREEPV(exp); @@ -4557,11 +4616,15 @@ Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags) restudied = 0; #endif - /* Set to use unicode semantics if the pattern is in utf8 and has the - * 'depends' charset specified, as it means unicode when utf8 */ pm_flags = orig_pm_flags; - if (RExC_utf8 && get_regex_charset(pm_flags) == REGEX_DEPENDS_CHARSET) { + if (initial_charset == REGEX_LOCALE_CHARSET) { + RExC_contains_locale = 1; + } + else if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) { + + /* Set to use unicode semantics if the pattern is in utf8 and has the + * 'depends' charset specified, as it means unicode when utf8 */ set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET); } @@ -4574,6 +4637,7 @@ Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags) RExC_seen_zerolen = *exp == '^' ? -1 : 0; RExC_seen_evals = 0; RExC_extralen = 0; + RExC_override_recoding = 0; /* First pass: determine size, legality. */ RExC_parse = exp; @@ -4960,7 +5024,7 @@ reStudy: data.longest = &(data.longest_fixed); first = scan; if (!ri->regstclass) { - cl_init(&ch_class); + cl_init(pRExC_state, &ch_class); data.start_class = &ch_class; stclass_flag = SCF_DO_STCLASS_AND; } else /* XXXX Check for BOUND? */ @@ -5143,7 +5207,7 @@ reStudy: DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n")); scan = ri->program + 1; - cl_init(&ch_class); + cl_init(pRExC_state, &ch_class); data.start_class = &ch_class; data.last_closep = &last_close; @@ -5764,123 +5828,181 @@ S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags) /* This section of code defines the inversion list object and its methods. The * interfaces are highly subject to change, so as much as possible is static to - * this file. An inversion list is here implemented as a malloc'd C array with - * some added info. More will be coming when functionality is added later. + * this file. An inversion list is here implemented as a malloc'd C UV array + * with some added info that is placed as UVs at the beginning in a header + * portion. An inversion list for Unicode is an array of code points, sorted + * by ordinal number. The zeroth element is the first code point in the list. + * The 1th element is the first element beyond that not in the list. In other + * words, the first range is + * invlist[0]..(invlist[1]-1) + * The other ranges follow. Thus every element that is divisible by two marks + * the beginning of a range that is in the list, and every element not + * divisible by two marks the beginning of a range not in the list. A single + * element inversion list that contains the single code point N generally + * consists of two elements + * invlist[0] == N + * invlist[1] == N+1 + * (The exception is when N is the highest representable value on the + * machine, in which case the list containing just it would be a single + * element, itself. By extension, if the last range in the list extends to + * infinity, then the first element of that range will be in the inversion list + * at a position that is divisible by two, and is the final element in the + * list.) + * Taking the complement (inverting) an inversion list is quite simple, if the + * first element is 0, remove it; otherwise add a 0 element at the beginning. + * This implementation reserves an element at the beginning of each inversion list + * to contain 0 when the list contains 0, and contains 1 otherwise. The actual + * beginning of the list is either that element if 0, or the next one if 1. + * + * More about inversion lists can be found in "Unicode Demystified" + * Chapter 13 by Richard Gillam, published by Addison-Wesley. + * More will be coming when functionality is added later. + * + * The inversion list data structure is currently implemented as an SV pointing + * to an array of UVs that the SV thinks are bytes. This allows us to have an + * array of UV whose memory management is automatically handled by the existing + * facilities for SV's. * * Some of the methods should always be private to the implementation, and some * should eventually be made public */ +#define INVLIST_LEN_OFFSET 0 /* Number of elements in the inversion list */ +#define INVLIST_ITER_OFFSET 1 /* Current iteration position */ + +#define INVLIST_ZERO_OFFSET 2 /* 0 or 1; must be last element in header */ +/* The UV at position ZERO contains either 0 or 1. If 0, the inversion list + * contains the code point U+00000, and begins here. If 1, the inversion list + * doesn't contain U+0000, and it begins at the next UV in the array. + * Inverting an inversion list consists of adding or removing the 0 at the + * beginning of it. By reserving a space for that 0, inversion can be made + * very fast */ + +#define HEADER_LENGTH (INVLIST_ZERO_OFFSET + 1) + +/* Internally things are UVs */ +#define TO_INTERNAL_SIZE(x) ((x + HEADER_LENGTH) * sizeof(UV)) +#define FROM_INTERNAL_SIZE(x) ((x / sizeof(UV)) - HEADER_LENGTH) + #define INVLIST_INITIAL_LEN 10 -#define INVLIST_ARRAY_KEY "array" -#define INVLIST_MAX_KEY "max" -#define INVLIST_LEN_KEY "len" PERL_STATIC_INLINE UV* -S_invlist_array(pTHX_ HV* const invlist) +S__invlist_array_init(pTHX_ SV* const invlist, const bool will_have_0) { - /* Returns the pointer to the inversion list's array. Every time the - * length changes, this needs to be called in case malloc or realloc moved - * it */ + /* Returns a pointer to the first element in the inversion list's array. + * This is called upon initialization of an inversion list. Where the + * array begins depends on whether the list has the code point U+0000 + * in it or not. The other parameter tells it whether the code that + * follows this call is about to put a 0 in the inversion list or not. + * The first element is either the element with 0, if 0, or the next one, + * if 1 */ - SV** list_ptr = hv_fetchs(invlist, INVLIST_ARRAY_KEY, FALSE); + UV* zero = get_invlist_zero_addr(invlist); - PERL_ARGS_ASSERT_INVLIST_ARRAY; + PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT; - if (list_ptr == NULL) { - Perl_croak(aTHX_ "panic: inversion list without a '%s' element", - INVLIST_ARRAY_KEY); - } + /* Must be empty */ + assert(! *get_invlist_len_addr(invlist)); - return INT2PTR(UV *, SvUV(*list_ptr)); + /* 1^1 = 0; 1^0 = 1 */ + *zero = 1 ^ will_have_0; + return zero + *zero; } -PERL_STATIC_INLINE void -S_invlist_set_array(pTHX_ HV* const invlist, const UV* const array) +PERL_STATIC_INLINE UV* +S_invlist_array(pTHX_ SV* const invlist) { - PERL_ARGS_ASSERT_INVLIST_SET_ARRAY; + /* Returns the pointer to the inversion list's array. Every time the + * length changes, this needs to be called in case malloc or realloc moved + * it */ - /* Sets the array stored in the inversion list to the memory beginning with - * the parameter */ + PERL_ARGS_ASSERT_INVLIST_ARRAY; - if (hv_stores(invlist, INVLIST_ARRAY_KEY, newSVuv(PTR2UV(array))) == NULL) { - Perl_croak(aTHX_ "panic: can't store '%s' entry in inversion list", - INVLIST_ARRAY_KEY); - } + /* Must not be empty */ + assert(*get_invlist_len_addr(invlist)); + assert(*get_invlist_zero_addr(invlist) == 0 + || *get_invlist_zero_addr(invlist) == 1); + + /* The array begins either at the element reserved for zero if the + * list contains 0 (that element will be set to 0), or otherwise the next + * element (in which case the reserved element will be set to 1). */ + return (UV *) (get_invlist_zero_addr(invlist) + + *get_invlist_zero_addr(invlist)); } -PERL_STATIC_INLINE UV -S_invlist_len(pTHX_ HV* const invlist) +PERL_STATIC_INLINE UV* +S_get_invlist_len_addr(pTHX_ SV* invlist) { - /* Returns the current number of elements in the inversion list's array */ - - SV** len_ptr = hv_fetchs(invlist, INVLIST_LEN_KEY, FALSE); - - PERL_ARGS_ASSERT_INVLIST_LEN; + /* Return the address of the UV that contains the current number + * of used elements in the inversion list */ - if (len_ptr == NULL) { - Perl_croak(aTHX_ "panic: inversion list without a '%s' element", - INVLIST_LEN_KEY); - } + PERL_ARGS_ASSERT_GET_INVLIST_LEN_ADDR; - return SvUV(*len_ptr); + return (UV *) (SvPVX(invlist) + (INVLIST_LEN_OFFSET * sizeof (UV))); } PERL_STATIC_INLINE UV -S_invlist_max(pTHX_ HV* const invlist) +S_invlist_len(pTHX_ SV* const invlist) { - /* Returns the maximum number of elements storable in the inversion list's - * array, without having to realloc() */ - - SV** max_ptr = hv_fetchs(invlist, INVLIST_MAX_KEY, FALSE); - - PERL_ARGS_ASSERT_INVLIST_MAX; + /* Returns the current number of elements in the inversion list's array */ - if (max_ptr == NULL) { - Perl_croak(aTHX_ "panic: inversion list without a '%s' element", - INVLIST_MAX_KEY); - } + PERL_ARGS_ASSERT_INVLIST_LEN; - return SvUV(*max_ptr); + return *get_invlist_len_addr(invlist); } PERL_STATIC_INLINE void -S_invlist_set_len(pTHX_ HV* const invlist, const UV len) +S_invlist_set_len(pTHX_ SV* const invlist, const UV len) { /* Sets the current number of elements stored in the inversion list */ PERL_ARGS_ASSERT_INVLIST_SET_LEN; - if (len != 0 && len > invlist_max(invlist)) { - Perl_croak(aTHX_ "panic: Can't make '%s=%"UVuf"' more than %s=%"UVuf" in inversion list", INVLIST_LEN_KEY, len, INVLIST_MAX_KEY, invlist_max(invlist)); - } - - if (hv_stores(invlist, INVLIST_LEN_KEY, newSVuv(len)) == NULL) { - Perl_croak(aTHX_ "panic: can't store '%s' entry in inversion list", - INVLIST_LEN_KEY); - } + *get_invlist_len_addr(invlist) = len; + + assert(len <= SvLEN(invlist)); + + SvCUR_set(invlist, TO_INTERNAL_SIZE(len)); + /* If the list contains U+0000, that element is part of the header, + * and should not be counted as part of the array. It will contain + * 0 in that case, and 1 otherwise. So we could flop 0=>1, 1=>0 and + * subtract: + * SvCUR_set(invlist, + * TO_INTERNAL_SIZE(len + * - (*get_invlist_zero_addr(inv_list) ^ 1))); + * But, this is only valid if len is not 0. The consequences of not doing + * this is that the memory allocation code may think that 1 more UV is + * being used than actually is, and so might do an unnecessary grow. That + * seems worth not bothering to make this the precise amount. + * + * Note that when inverting, SvCUR shouldn't change */ } -PERL_STATIC_INLINE void -S_invlist_set_max(pTHX_ HV* const invlist, const UV max) +PERL_STATIC_INLINE UV +S_invlist_max(pTHX_ SV* const invlist) { + /* Returns the maximum number of elements storable in the inversion list's + * array, without having to realloc() */ - /* Sets the maximum number of elements storable in the inversion list - * without having to realloc() */ + PERL_ARGS_ASSERT_INVLIST_MAX; - PERL_ARGS_ASSERT_INVLIST_SET_MAX; + return FROM_INTERNAL_SIZE(SvLEN(invlist)); +} - if (max < invlist_len(invlist)) { - Perl_croak(aTHX_ "panic: Can't make '%s=%"UVuf"' less than %s=%"UVuf" in inversion list", INVLIST_MAX_KEY, invlist_len(invlist), INVLIST_LEN_KEY, invlist_max(invlist)); - } +PERL_STATIC_INLINE UV* +S_get_invlist_zero_addr(pTHX_ SV* invlist) +{ + /* Return the address of the UV that is reserved to hold 0 if the inversion + * list contains 0. This has to be the last element of the heading, as the + * list proper starts with either it if 0, or the next element if not. + * (But we force it to contain either 0 or 1) */ - if (hv_stores(invlist, INVLIST_MAX_KEY, newSVuv(max)) == NULL) { - Perl_croak(aTHX_ "panic: can't store '%s' entry in inversion list", - INVLIST_LEN_KEY); - } + PERL_ARGS_ASSERT_GET_INVLIST_ZERO_ADDR; + + return (UV *) (SvPVX(invlist) + (INVLIST_ZERO_OFFSET * sizeof (UV))); } #ifndef PERL_IN_XSUB_RE -HV* +SV* Perl__new_invlist(pTHX_ IV initial_size) { @@ -5888,99 +6010,72 @@ Perl__new_invlist(pTHX_ IV initial_size) * space to store 'initial_size' elements. If that number is negative, a * system default is used instead */ - HV* invlist = newHV(); - UV* list; + SV* new_list; if (initial_size < 0) { initial_size = INVLIST_INITIAL_LEN; } /* Allocate the initial space */ - Newx(list, initial_size, UV); - invlist_set_array(invlist, list); - - /* set_len has to come before set_max, as the latter inspects the len */ - invlist_set_len(invlist, 0); - invlist_set_max(invlist, initial_size); - - return invlist; -} -#endif + new_list = newSV(TO_INTERNAL_SIZE(initial_size)); + invlist_set_len(new_list, 0); -PERL_STATIC_INLINE void -S_invlist_destroy(pTHX_ HV* const invlist) -{ - /* Inversion list destructor */ + /* Force iterinit() to be used to get iteration to work */ + *get_invlist_iter_addr(new_list) = UV_MAX; - SV** list_ptr = hv_fetchs(invlist, INVLIST_ARRAY_KEY, FALSE); + /* This should force a segfault if a method doesn't initialize this + * properly */ + *get_invlist_zero_addr(new_list) = UV_MAX; - PERL_ARGS_ASSERT_INVLIST_DESTROY; - - if (list_ptr != NULL) { - UV *list = INT2PTR(UV *, SvUV(*list_ptr)); /* PERL_POISON needs lvalue */ - Safefree(list); - } + return new_list; } +#endif STATIC void -S_invlist_extend(pTHX_ HV* const invlist, const UV new_max) +S_invlist_extend(pTHX_ SV* const invlist, const UV new_max) { - /* Change the maximum size of an inversion list (up or down) */ - - UV* orig_array; - UV* array; - const UV old_max = invlist_max(invlist); + /* Grow the maximum size of an inversion list */ PERL_ARGS_ASSERT_INVLIST_EXTEND; - if (old_max == new_max) { /* If a no-op */ - return; - } - - array = orig_array = invlist_array(invlist); - Renew(array, new_max, UV); - - /* If the size change moved the list in memory, set the new one */ - if (array != orig_array) { - invlist_set_array(invlist, array); - } - - invlist_set_max(invlist, new_max); - + SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max)); } PERL_STATIC_INLINE void -S_invlist_trim(pTHX_ HV* const invlist) +S_invlist_trim(pTHX_ SV* const invlist) { PERL_ARGS_ASSERT_INVLIST_TRIM; /* Change the length of the inversion list to how many entries it currently * has */ - invlist_extend(invlist, invlist_len(invlist)); + SvPV_shrink_to_cur((SV *) invlist); } /* An element is in an inversion list iff its index is even numbered: 0, 2, 4, * etc */ #define ELEMENT_IN_INVLIST_SET(i) (! ((i) & 1)) +#define PREV_ELEMENT_IN_INVLIST_SET(i) (! ELEMENT_IN_INVLIST_SET(i)) #ifndef PERL_IN_XSUB_RE void -Perl__append_range_to_invlist(pTHX_ HV* const invlist, const UV start, const UV end) +Perl__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end) { /* Subject to change or removal. Append the range from 'start' to 'end' at * the end of the inversion list. The range must be above any existing * ones. */ - UV* array = invlist_array(invlist); + UV* array; UV max = invlist_max(invlist); UV len = invlist_len(invlist); PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST; - if (len > 0) { - + if (len == 0) { /* Empty lists must be initialized */ + array = _invlist_array_init(invlist, start == 0); + } + else { /* Here, the existing list is non-empty. The current max entry in the * list is generally the first value not in the set, except when the * set extends to the end of permissible values, in which case it is @@ -5988,6 +6083,7 @@ Perl__append_range_to_invlist(pTHX_ HV* const invlist, const UV start, const UV * append out-of-order */ UV final_element = len - 1; + array = invlist_array(invlist); if (array[final_element] > start || ELEMENT_IN_INVLIST_SET(final_element)) { @@ -6019,10 +6115,13 @@ Perl__append_range_to_invlist(pTHX_ HV* const invlist, const UV start, const UV * moved */ if (max < len) { invlist_extend(invlist, len); + invlist_set_len(invlist, len); /* Have to set len here to avoid assert + failure in invlist_array() */ array = invlist_array(invlist); } - - invlist_set_len(invlist, len); + else { + invlist_set_len(invlist, len); + } /* The next item on the list starts the range, the one after that is * one past the new range. */ @@ -6036,12 +6135,13 @@ Perl__append_range_to_invlist(pTHX_ HV* const invlist, const UV start, const UV invlist_set_len(invlist, len - 1); } } -#endif -STATIC HV* -S_invlist_union(pTHX_ HV* const a, HV* const b) +void +Perl__invlist_union(pTHX_ SV* const a, SV* const b, SV** output) { - /* Return a new inversion list which is the union of two inversion lists. + /* Take the union of two inversion lists and point 'result' to it. If + * 'result' on input points to one of the two lists, the reference count to + * that list will be decremented. * The basis for this comes from "Unicode Demystified" Chapter 13 by * Richard Gillam, published by Addison-Wesley, and explained at some * length there. The preface says to incorporate its examples into your @@ -6052,14 +6152,15 @@ S_invlist_union(pTHX_ HV* const a, HV* const b) * XXX A potential performance improvement is to keep track as we go along * if only one of the inputs contributes to the result, meaning the other * is a subset of that one. In that case, we can skip the final copy and - * return the larger of the input lists */ + * return the larger of the input lists, but then outside code might need + * to keep track of whether to free the input list or not */ - UV* array_a = invlist_array(a); /* a's array */ - UV* array_b = invlist_array(b); - UV len_a = invlist_len(a); /* length of a's array */ - UV len_b = invlist_len(b); + UV* array_a; /* a's array */ + UV* array_b; + UV len_a; /* length of a's array */ + UV len_b; - HV* u; /* the resulting union */ + SV* u; /* the resulting union */ UV* array_u; UV len_u; @@ -6075,12 +6176,42 @@ S_invlist_union(pTHX_ HV* const a, HV* const b) */ UV count = 0; - PERL_ARGS_ASSERT_INVLIST_UNION; + PERL_ARGS_ASSERT__INVLIST_UNION; + + /* If either one is empty, the union is the other one */ + len_a = invlist_len(a); + if (len_a == 0) { + if (output == &a) { + SvREFCNT_dec(a); + } + else if (output != &b) { + *output = invlist_clone(b); + } + /* else *output already = b; */ + return; + } + else if ((len_b = invlist_len(b)) == 0) { + if (output == &b) { + SvREFCNT_dec(b); + } + else if (output != &a) { + *output = invlist_clone(a); + } + /* else *output already = a; */ + return; + } + + /* Here both lists exist and are non-empty */ + array_a = invlist_array(a); + array_b = invlist_array(b); /* Size the union for the worst case: that the sets are completely * disjoint */ u = _new_invlist(len_a + len_b); - array_u = invlist_array(u); + + /* Will contain U+0000 if either component does */ + array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0) + || (len_b > 0 && array_b[0] == 0)); /* Go through each list item by item, stopping when exhausted one of * them */ @@ -6130,9 +6261,9 @@ S_invlist_union(pTHX_ HV* const a, HV* const b) /* Here, we are finished going through at least one of the lists, which * means there is something remaining in at most one. We check if the list * that hasn't been exhausted is positioned such that we are in the middle - * of a range in its set or not. (We are in the set if the next item in - * the array marks the beginning of something not in the set) If in the - * set, we decrement 'count'; if 0, there is potentially more to output. + * of a range in its set or not. (i_a and i_b point to the element beyond + * the one we care about.) If in the set, we decrement 'count'; if 0, there + * is potentially more to output. * There are four cases: * 1) Both weren't in their sets, count is 0, and remains 0. What's left * in the union is entirely from the non-exhausted set. @@ -6142,12 +6273,12 @@ S_invlist_union(pTHX_ HV* const a, HV* const b) * that * 3) the exhausted was in its set, non-exhausted isn't, count is 1. * Nothing further should be output because the union includes - * everything from the exhausted set. Not decrementing insures that. + * everything from the exhausted set. Not decrementing ensures that. * 4) the exhausted wasn't in its set, non-exhausted is, count is 1; * decrementing to 0 insures that we look at the remainder of the * non-exhausted set */ - if ((i_a != len_a && ! ELEMENT_IN_INVLIST_SET(i_a)) - || (i_b != len_b && ! ELEMENT_IN_INVLIST_SET(i_b))) + if ((i_a != len_a && PREV_ELEMENT_IN_INVLIST_SET(i_a)) + || (i_b != len_b && PREV_ELEMENT_IN_INVLIST_SET(i_b))) { count--; } @@ -6186,27 +6317,36 @@ S_invlist_union(pTHX_ HV* const a, HV* const b) } } - return u; + /* We may be removing a reference to one of the inputs */ + if (&a == output || &b == output) { + SvREFCNT_dec(*output); + } + + *output = u; + return; } -STATIC HV* -S_invlist_intersection(pTHX_ HV* const a, HV* const b) +void +Perl__invlist_intersection(pTHX_ SV* const a, SV* const b, SV** i) { - /* Return the intersection of two inversion lists. The basis for this - * comes from "Unicode Demystified" Chapter 13 by Richard Gillam, published - * by Addison-Wesley, and explained at some length there. The preface says - * to incorporate its examples into your code at your own risk. + /* Take the intersection of two inversion lists and point 'i' to it. If + * 'i' on input points to one of the two lists, the reference count to that + * list will be decremented. + * The basis for this comes from "Unicode Demystified" Chapter 13 by + * Richard Gillam, published by Addison-Wesley, and explained at some + * length there. The preface says to incorporate its examples into your + * code at your own risk. In fact, it had bugs * * The algorithm is like a merge sort, and is essentially the same as the * union above */ - UV* array_a = invlist_array(a); /* a's array */ - UV* array_b = invlist_array(b); - UV len_a = invlist_len(a); /* length of a's array */ - UV len_b = invlist_len(b); + UV* array_a; /* a's array */ + UV* array_b; + UV len_a; /* length of a's array */ + UV len_b; - HV* r; /* the resulting intersection */ + SV* r; /* the resulting intersection */ UV* array_r; UV len_r; @@ -6222,12 +6362,35 @@ S_invlist_intersection(pTHX_ HV* const a, HV* const b) */ UV count = 0; - PERL_ARGS_ASSERT_INVLIST_INTERSECTION; + PERL_ARGS_ASSERT__INVLIST_INTERSECTION; + + /* If either one is empty, the intersection is null */ + len_a = invlist_len(a); + if ((len_a == 0) || ((len_b = invlist_len(b)) == 0)) { + *i = _new_invlist(0); + + /* If the result is the same as one of the inputs, the input is being + * overwritten */ + if (i == &a) { + SvREFCNT_dec(a); + } + else if (i == &b) { + SvREFCNT_dec(b); + } + return; + } + + /* Here both lists exist and are non-empty */ + array_a = invlist_array(a); + array_b = invlist_array(b); /* Size the intersection for the worst case: that the intersection ends up * fragmenting everything to be completely disjoint */ r= _new_invlist(len_a + len_b); - array_r = invlist_array(r); + + /* Will contain U+0000 iff both components do */ + array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0 + && len_b > 0 && array_b[0] == 0); /* Go through each list item by item, stopping when exhausted one of * them */ @@ -6236,17 +6399,17 @@ S_invlist_intersection(pTHX_ HV* const a, HV* const b) array */ bool cp_in_set; /* Is it in the input list's set or not */ - /* We need to take one or the other of the two inputs for the union. - * Since we are merging two sorted lists, we take the smaller of the - * next items. In case of a tie, we take the one that is not in its - * set first (a difference from the union algorithm). If we took one - * in the set first, it would increment the count, possibly to 2 which - * would cause it to be output as starting a range in the intersection, - * and the next time through we would take that same number, and output - * it again as ending the set. By doing it the opposite of this, we - * there is no possibility that the count will be momentarily - * incremented to 2. (In a tie and both are in the set or both not in - * the set, it doesn't matter which we take first.) */ + /* We need to take one or the other of the two inputs for the + * intersection. Since we are merging two sorted lists, we take the + * smaller of the next items. In case of a tie, we take the one that + * is not in its set first (a difference from the union algorithm). If + * we took one in the set first, it would increment the count, possibly + * to 2 which would cause it to be output as starting a range in the + * intersection, and the next time through we would take that same + * number, and output it again as ending the set. By doing it the + * opposite of this, there is no possibility that the count will be + * momentarily incremented to 2. (In a tie and both are in the set or + * both not in the set, it doesn't matter which we take first.) */ if (array_a[i_a] < array_b[i_b] || (array_a[i_a] == array_b[i_b] && ! ELEMENT_IN_INVLIST_SET(i_a))) { @@ -6275,19 +6438,32 @@ S_invlist_intersection(pTHX_ HV* const a, HV* const b) } } - /* Here, we are finished going through at least one of the sets, which - * means there is something remaining in at most one. See the comments in - * the union code */ - if ((i_a != len_a && ! ELEMENT_IN_INVLIST_SET(i_a)) - || (i_b != len_b && ! ELEMENT_IN_INVLIST_SET(i_b))) + /* Here, we are finished going through at least one of the lists, which + * means there is something remaining in at most one. We check if the list + * that has been exhausted is positioned such that we are in the middle + * of a range in its set or not. (i_a and i_b point to elements 1 beyond + * the ones we care about.) There are four cases: + * 1) Both weren't in their sets, count is 0, and remains 0. There's + * nothing left in the intersection. + * 2) Both were in their sets, count is 2 and perhaps is incremented to + * above 2. What should be output is exactly that which is in the + * non-exhausted set, as everything it has is also in the intersection + * set, and everything it doesn't have can't be in the intersection + * 3) The exhausted was in its set, non-exhausted isn't, count is 1, and + * gets incremented to 2. Like the previous case, the intersection is + * everything that remains in the non-exhausted set. + * 4) the exhausted wasn't in its set, non-exhausted is, count is 1, and + * remains 1. And the intersection has nothing more. */ + if ((i_a == len_a && PREV_ELEMENT_IN_INVLIST_SET(i_a)) + || (i_b == len_b && PREV_ELEMENT_IN_INVLIST_SET(i_b))) { - count--; + count++; } /* The final length is what we've output so far plus what else is in the - * intersection. Only 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) { + if (count >= 2) { len_r += (len_a - i_a) + (len_b - i_b); } @@ -6300,7 +6476,7 @@ S_invlist_intersection(pTHX_ HV* const a, HV* const b) } /* Finish outputting any remaining */ - if (count == 2) { /* Only one of will have a non-zero copy count */ + if (count >= 2) { /* At most one will have a non-zero copy count */ IV copy_count; if ((copy_count = len_a - i_a) > 0) { Copy(array_a + i_a, array_r + i_r, copy_count, UV); @@ -6310,11 +6486,19 @@ S_invlist_intersection(pTHX_ HV* const a, HV* const b) } } - return r; + /* We may be removing a reference to one of the inputs */ + if (&a == i || &b == i) { + SvREFCNT_dec(*i); + } + + *i = r; + return; } -STATIC HV* -S_add_range_to_invlist(pTHX_ HV* invlist, const UV start, const UV end) +#endif + +STATIC SV* +S_add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end) { /* Add the range from 'start' to 'end' inclusive to the inversion list's * set. A pointer to the inversion list is returned. This may actually be @@ -6322,8 +6506,7 @@ S_add_range_to_invlist(pTHX_ HV* invlist, const UV start, const UV end) * passed in inversion list can be NULL, in which case a new one is created * with just the one range in it */ - HV* range_invlist; - HV* added_invlist; + SV* range_invlist; UV len; if (invlist == NULL) { @@ -6348,22 +6531,214 @@ S_add_range_to_invlist(pTHX_ HV* invlist, const UV start, const UV end) range_invlist = _new_invlist(2); _append_range_to_invlist(range_invlist, start, end); - added_invlist = invlist_union(invlist, range_invlist); + _invlist_union(invlist, range_invlist, &invlist); - /* The passed in list can be freed, as well as our temporary */ - invlist_destroy(range_invlist); - if (invlist != added_invlist) { - invlist_destroy(invlist); - } + /* The temporary can be freed */ + SvREFCNT_dec(range_invlist); - return added_invlist; + return invlist; } -PERL_STATIC_INLINE HV* -S_add_cp_to_invlist(pTHX_ HV* invlist, const UV cp) { +PERL_STATIC_INLINE SV* +S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) { return add_range_to_invlist(invlist, cp, cp); } +#ifndef PERL_IN_XSUB_RE +void +Perl__invlist_invert(pTHX_ SV* const invlist) +{ + /* Complement the input inversion list. This adds a 0 if the list didn't + * have a zero; removes it otherwise. As described above, the data + * structure is set up so that this is very efficient */ + + UV* len_pos = get_invlist_len_addr(invlist); + + PERL_ARGS_ASSERT__INVLIST_INVERT; + + /* The inverse of matching nothing is matching everything */ + if (*len_pos == 0) { + _append_range_to_invlist(invlist, 0, UV_MAX); + return; + } + + /* The exclusive or complents 0 to 1; and 1 to 0. If the result is 1, the + * zero element was a 0, so it is being removed, so the length decrements + * by 1; and vice-versa. SvCUR is unaffected */ + if (*get_invlist_zero_addr(invlist) ^= 1) { + (*len_pos)--; + } + else { + (*len_pos)++; + } +} + +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); + array[len - 1] = PERL_UNICODE_MAX + 1; + } + else { /* Remove the 0x110000 */ + invlist_set_len(invlist, len - 1); + } + } + + return; +} +#endif + +PERL_STATIC_INLINE SV* +S_invlist_clone(pTHX_ SV* const invlist) +{ + + /* Return a new inversion list that is a copy of the input one, which is + * unchanged */ + + SV* new_invlist = _new_invlist(SvCUR(invlist)); + + PERL_ARGS_ASSERT_INVLIST_CLONE; + + Copy(SvPVX(invlist), SvPVX(new_invlist), SvCUR(invlist), char); + return new_invlist; +} + +#ifndef PERL_IN_XSUB_RE +void +Perl__invlist_subtract(pTHX_ SV* const a, SV* const b, SV** result) +{ + /* Point result to an inversion list which consists of all elements in 'a' + * that aren't also in 'b' */ + + PERL_ARGS_ASSERT__INVLIST_SUBTRACT; + + /* Subtracting nothing retains the original */ + if (invlist_len(b) == 0) { + + /* If the result is not to be the same variable as the original, create + * a copy */ + if (result != &a) { + *result = invlist_clone(a); + } + } else { + SV *b_copy = invlist_clone(b); + _invlist_invert(b_copy); /* Everything not in 'b' */ + _invlist_intersection(a, b_copy, result); /* Everything in 'a' not in + 'b' */ + SvREFCNT_dec(b_copy); + } + + if (result == &b) { + SvREFCNT_dec(b); + } + + return; +} +#endif + +PERL_STATIC_INLINE UV* +S_get_invlist_iter_addr(pTHX_ SV* invlist) +{ + /* Return the address of the UV that contains the current iteration + * position */ + + PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR; + + return (UV *) (SvPVX(invlist) + (INVLIST_ITER_OFFSET * sizeof (UV))); +} + +PERL_STATIC_INLINE void +S_invlist_iterinit(pTHX_ SV* invlist) /* Initialize iterator for invlist */ +{ + PERL_ARGS_ASSERT_INVLIST_ITERINIT; + + *get_invlist_iter_addr(invlist) = 0; +} + +STATIC bool +S_invlist_iternext(pTHX_ SV* invlist, UV* start, UV* end) +{ + UV* pos = get_invlist_iter_addr(invlist); + UV len = invlist_len(invlist); + UV *array; + + PERL_ARGS_ASSERT_INVLIST_ITERNEXT; + + if (*pos >= len) { + *pos = UV_MAX; /* Force iternit() to be required next time */ + return FALSE; + } + + array = invlist_array(invlist); + + *start = array[(*pos)++]; + + if (*pos >= len) { + *end = UV_MAX; + } + else { + *end = array[(*pos)++] - 1; + } + + return TRUE; +} + +#if 0 +void +S_invlist_dump(pTHX_ SV* const invlist, const char * const header) +{ + /* Dumps out the ranges in an inversion list. The string 'header' + * if present is output on a line before the first range */ + + UV start, end; + + if (header && strlen(header)) { + PerlIO_printf(Perl_debug_log, "%s\n", header); + } + invlist_iterinit(invlist); + while (invlist_iternext(invlist, &start, &end)) { + if (end == UV_MAX) { + PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. INFINITY\n", start); + } + else { + PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. 0x%04"UVXf"\n", start, end); + } + } +} +#endif + +#undef HEADER_LENGTH +#undef INVLIST_INITIAL_LENGTH +#undef TO_INTERNAL_SIZE +#undef FROM_INTERNAL_SIZE +#undef INVLIST_LEN_OFFSET +#undef INVLIST_ZERO_OFFSET +#undef INVLIST_ITER_OFFSET + /* End of inversion list object */ /* @@ -6653,6 +7028,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) 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))) SvREFCNT_dec(svname); #endif @@ -7007,7 +7383,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) { U32 posflags = 0, negflags = 0; U32 *flagsp = &posflags; - bool has_charset_modifier = 0; + char has_charset_modifier = '\0'; regex_charset cs = (RExC_utf8 || RExC_uni_semantics) ? REGEX_UNICODE_CHARSET : REGEX_DEPENDS_CHARSET; @@ -7019,39 +7395,51 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) switch (*RExC_parse) { CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp); case LOCALE_PAT_MOD: - if (has_charset_modifier || flagsp == &negflags) { - goto fail_modifiers; + if (has_charset_modifier) { + goto excess_modifier; + } + else if (flagsp == &negflags) { + goto neg_modifier; } cs = REGEX_LOCALE_CHARSET; - has_charset_modifier = 1; + has_charset_modifier = LOCALE_PAT_MOD; + RExC_contains_locale = 1; break; case UNICODE_PAT_MOD: - if (has_charset_modifier || flagsp == &negflags) { - goto fail_modifiers; + if (has_charset_modifier) { + goto excess_modifier; + } + else if (flagsp == &negflags) { + goto neg_modifier; } cs = REGEX_UNICODE_CHARSET; - has_charset_modifier = 1; + has_charset_modifier = UNICODE_PAT_MOD; break; case ASCII_RESTRICT_PAT_MOD: - if (has_charset_modifier || flagsp == &negflags) { - goto fail_modifiers; + if (flagsp == &negflags) { + goto neg_modifier; } - if (*(RExC_parse + 1) == ASCII_RESTRICT_PAT_MOD) { + if (has_charset_modifier) { + if (cs != REGEX_ASCII_RESTRICTED_CHARSET) { + goto excess_modifier; + } /* Doubled modifier implies more restricted */ - cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET; - RExC_parse++; - } + cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET; + } else { cs = REGEX_ASCII_RESTRICTED_CHARSET; } - has_charset_modifier = 1; + has_charset_modifier = ASCII_RESTRICT_PAT_MOD; break; case DEPENDS_PAT_MOD: - if (has_use_defaults - || has_charset_modifier - || flagsp == &negflags) - { + if (has_use_defaults) { goto fail_modifiers; + } + else if (flagsp == &negflags) { + goto neg_modifier; + } + else if (has_charset_modifier) { + goto excess_modifier; } /* The dual charset means unicode semantics if the @@ -7061,8 +7449,24 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) cs = (RExC_utf8 || RExC_uni_semantics) ? REGEX_UNICODE_CHARSET : REGEX_DEPENDS_CHARSET; - has_charset_modifier = 1; + has_charset_modifier = DEPENDS_PAT_MOD; break; + excess_modifier: + RExC_parse++; + if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) { + 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)); + } + else { + vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1)); + } + /*NOTREACHED*/ + neg_modifier: + RExC_parse++; + 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)) { @@ -7413,7 +7817,9 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) const char * const origparse = RExC_parse; I32 min; I32 max = REG_INFTY; +#ifdef RE_TRACK_PATTERN_OFFSETS char *parse_start; +#endif const char *maxpos = NULL; GET_RE_DEBUG_FLAGS_DECL; @@ -7432,7 +7838,9 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) if (op == '{' && regcurly(RExC_parse)) { maxpos = NULL; +#ifdef RE_TRACK_PATTERN_OFFSETS parse_start = RExC_parse; /* MJD */ +#endif next = RExC_parse + 1; while (isDIGIT(*next) || *next == ',') { if (*next == ',') { @@ -7528,7 +7936,9 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) vFAIL("Regexp *+ operand could be empty"); #endif +#ifdef RE_TRACK_PATTERN_OFFSETS parse_start = RExC_parse; +#endif nextchar(pRExC_state); *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH); @@ -7592,7 +8002,7 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) } -/* reg_namedseq(pRExC_state,UVp) +/* reg_namedseq(pRExC_state,UVp, UV depth) This is expected to be called by a parser routine that has recognized '\N' and needs to handle the rest. RExC_parse is @@ -7635,13 +8045,10 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) Parsing failures will generate a fatal error via vFAIL(...) */ STATIC regnode * -S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp) +S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp, U32 depth) { char * endbrace; /* '}' following the name */ regnode *ret = NULL; -#ifdef DEBUGGING - char* parse_start = RExC_parse - 2; /* points to the '\N' */ -#endif char* p; GET_RE_DEBUG_FLAGS_DECL; @@ -7754,168 +8161,55 @@ S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp) ret = (regnode *) &RExC_parse; /* Invalid regnode pointer */ } else { /* Not a char class */ - char *s; /* String to put in generated EXACT node */ - STRLEN len = 0; /* Its current byte length */ + + /* What is done here is to convert this to a sub-pattern of the form + * (?:\x{char1}\x{char2}...) + * and then call reg recursively. That way, it retains its atomicness, + * while not having to worry about special handling that some code + * points may have. toke.c has converted the original Unicode values + * to native, so that we can just pass on the hex values unchanged. We + * do have to set a flag to keep recoding from happening in the + * recursion */ + + SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP); + STRLEN len; char *endchar; /* Points to '.' or '}' ending cur char in the input stream */ - ret = reg_node(pRExC_state, - (U8) ((! FOLD) ? EXACT - : (LOC) - ? EXACTFL - : (MORE_ASCII_RESTRICTED) - ? EXACTFA - : (AT_LEAST_UNI_SEMANTICS) - ? EXACTFU - : EXACTF)); - s= STRING(ret); - - /* Exact nodes can hold only a U8 length's of text = 255. Loop through - * the input which is of the form now 'c1.c2.c3...}' until find the - * ending brace or exceed length 255. The characters that exceed this - * limit are dropped. The limit could be relaxed should it become - * desirable by reparsing this as (?:\N{NAME}), so could generate - * multiple EXACT nodes, as is done for just regular input. But this - * is primarily a named character, and not intended to be a huge long - * string, so 255 bytes should be good enough */ - while (1) { - STRLEN length_of_hex; - I32 grok_flags = PERL_SCAN_ALLOW_UNDERSCORES - | PERL_SCAN_DISALLOW_PREFIX - | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0); - UV cp; /* Ord of current character */ - bool use_this_char_fold = FOLD; + char *orig_end = RExC_end; + + while (RExC_parse < endbrace) { /* Code points are separated by dots. If none, there is only one * code point, and is terminated by the brace */ endchar = RExC_parse + strcspn(RExC_parse, ".}"); - /* The values are Unicode even on EBCDIC machines */ - length_of_hex = (STRLEN)(endchar - RExC_parse); - cp = grok_hex(RExC_parse, &length_of_hex, &grok_flags, NULL); - if ( length_of_hex == 0 - || length_of_hex != (STRLEN)(endchar - RExC_parse) ) - { - RExC_parse += length_of_hex; /* Includes all the valid */ - RExC_parse += (RExC_orig_utf8) /* point to after 1st invalid */ - ? UTF8SKIP(RExC_parse) - : 1; - /* Guard against malformed utf8 */ - if (RExC_parse >= endchar) RExC_parse = endchar; - vFAIL("Invalid hexadecimal number in \\N{U+...}"); - } - - /* XXX ? Change to ANYOF node - if (FOLD - && (cp > 255 || (! MORE_ASCII_RESTRICTED && ! LOC)) - && is_TRICKYFOLD_cp(cp)) - { - } - */ - - /* Under /aa, we can't mix ASCII with non- in a fold. If we are - * folding, and the source isn't ASCII, look through all the - * characters it folds to. If any one of them is ASCII, forbid - * this fold. (cp is uni, so the 127 below is correct even for - * EBCDIC). Similarly under locale rules, we don't mix under 256 - * with above 255. XXX It really doesn't make sense to have \N{} - * which means a Unicode rules under locale. I (khw) think this - * should be warned about, but the counter argument is that people - * who have programmed around Perl's earlier lack of specifying the - * rules and used \N{} to force Unicode things in a local - * environment shouldn't get suddenly a warning */ - if (use_this_char_fold) { - if (LOC && cp < 256) { /* Fold not known until run-time */ - use_this_char_fold = FALSE; - } - else if ((cp > 127 && MORE_ASCII_RESTRICTED) - || (cp > 255 && LOC)) - { - U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; - U8* s = tmpbuf; - U8* e; - STRLEN foldlen; - - (void) toFOLD_uni(cp, tmpbuf, &foldlen); - e = s + foldlen; - - while (s < e) { - if (isASCII(*s) - || (LOC && (UTF8_IS_INVARIANT(*s) - || UTF8_IS_DOWNGRADEABLE_START(*s)))) - { - use_this_char_fold = FALSE; - break; - } - s += UTF8SKIP(s); - } - } - } - - if (! use_this_char_fold) { /* Not folding, just append to the - string */ - STRLEN unilen; - - /* Quit before adding this character if would exceed limit */ - if (len + UNISKIP(cp) > U8_MAX) break; - - unilen = reguni(pRExC_state, cp, s); - if (unilen > 0) { - s += unilen; - len += unilen; - } - } else { /* Folding, output the folded equivalent */ - STRLEN foldlen,numlen; - U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf; - cp = toFOLD_uni(cp, tmpbuf, &foldlen); - - /* Quit before exceeding size limit */ - if (len + foldlen > U8_MAX) break; - - for (foldbuf = tmpbuf; - foldlen; - foldlen -= numlen) - { - cp = utf8_to_uvchr(foldbuf, &numlen); - if (numlen > 0) { - const STRLEN unilen = reguni(pRExC_state, cp, s); - s += unilen; - len += unilen; - /* In EBCDIC the numlen and unilen can differ. */ - foldbuf += numlen; - if (numlen >= foldlen) - break; - } - else - break; /* "Can't happen." */ - } - } + /* Convert to notation the rest of the code understands */ + sv_catpv(substitute_parse, "\\x{"); + sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse); + sv_catpv(substitute_parse, "}"); /* Point to the beginning of the next character in the sequence. */ RExC_parse = endchar + 1; - - /* Quit if no more characters */ - if (RExC_parse >= endbrace) break; } + sv_catpv(substitute_parse, ")"); + RExC_parse = SvPV(substitute_parse, len); - if (SIZE_ONLY) { - if (RExC_parse < endbrace) { - ckWARNreg(RExC_parse - 1, - "Using just the first characters returned by \\N{}"); - } - - RExC_size += STR_SZ(len); - } else { - STR_LEN(ret) = len; - RExC_emit += STR_SZ(len); + /* Don't allow empty number */ + if (len < 8) { + vFAIL("Invalid hexadecimal number in \\N{U+...}"); } + RExC_end = RExC_parse + len; - RExC_parse = endbrace + 1; + /* The values are Unicode, and therefore not subject to recoding */ + RExC_override_recoding = 1; + + ret = reg(pRExC_state, 1, flagp, depth+1); + + RExC_parse = endbrace; + RExC_end = orig_end; + RExC_override_recoding = 0; - *flagp |= HASWIDTH; /* Not SIMPLE, as that causes the engine to fail - with malformed in t/re/pat_advanced.t */ - RExC_parse --; - Set_Node_Cur_Length(ret); /* MJD */ nextchar(pRExC_state); } @@ -8078,27 +8372,6 @@ tryagain: RExC_parse++; vFAIL("Quantifier follows nothing"); break; - case LATIN_SMALL_LETTER_SHARP_S: - case UTF8_TWO_BYTE_HI_nocast(LATIN_SMALL_LETTER_SHARP_S): - case UTF8_TWO_BYTE_HI_nocast(IOTA_D_T): -#if UTF8_TWO_BYTE_HI_nocast(UPSILON_D_T) != UTF8_TWO_BYTE_HI_nocast(IOTA_D_T) -#error The beginning utf8 byte of IOTA_D_T and UPSILON_D_T unexpectedly differ. Other instances in this code should have the case statement below. - case UTF8_TWO_BYTE_HI_nocast(UPSILON_D_T): -#endif - do_foldchar: - if (!LOC && FOLD) { - U32 len,cp; - len=0; /* silence a spurious compiler warning */ - if ((cp = what_len_TRICKYFOLD_safe(RExC_parse,RExC_end,UTF,len))) { - *flagp |= HASWIDTH; /* could be SIMPLE too, but needs a handler in regexec.regrepeat */ - RExC_parse+=len-1; /* we get one from nextchar() as well. :-( */ - ret = reganode(pRExC_state, FOLDCHAR, cp); - Set_Node_Length(ret, 1); /* MJD */ - nextchar(pRExC_state); /* kill whitespace under /x */ - return ret; - } - } - goto outer_default; case '\\': /* Special Escapes @@ -8113,10 +8386,6 @@ tryagain: literal text handling code. */ switch ((U8)*++RExC_parse) { - case LATIN_SMALL_LETTER_SHARP_S: - case UTF8_TWO_BYTE_HI_nocast(LATIN_SMALL_LETTER_SHARP_S): - case UTF8_TWO_BYTE_HI_nocast(IOTA_D_T): - goto do_foldchar; /* Special Escapes */ case 'A': RExC_seen_zerolen++; @@ -8399,7 +8668,7 @@ tryagain: Also this makes sure that things like /\N{BLAH}+/ and \N{BLAH} being multi char Just Happen. dmq*/ ++RExC_parse; - ret= reg_namedseq(pRExC_state, NULL, flagp); + ret= reg_namedseq(pRExC_state, NULL, flagp, depth); break; case 'k': /* Handle \k and \k'NAME' */ parse_named_seq: @@ -8537,7 +8806,21 @@ tryagain: /* FALL THROUGH */ default: - outer_default:{ + + parse_start = RExC_parse - 1; + + RExC_parse++; + + defchar: { + typedef enum { + generic_char = 0, + char_s, + upsilon_1, + upsilon_2, + iota_1, + iota_2, + } char_state; + char_state latest_char_state = generic_char; register STRLEN len; register UV ender; register char *p; @@ -8546,11 +8829,6 @@ tryagain: U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf; regnode * orig_emit; - parse_start = RExC_parse - 1; - - RExC_parse++; - - defchar: ender = 0; orig_emit = RExC_emit; /* Save the original output node position in case we need to output a different node @@ -8575,11 +8853,6 @@ tryagain: if (RExC_flags & RXf_PMf_EXTENDED) p = regwhite( pRExC_state, p ); switch ((U8)*p) { - case LATIN_SMALL_LETTER_SHARP_S: - case UTF8_TWO_BYTE_HI_nocast(LATIN_SMALL_LETTER_SHARP_S): - case UTF8_TWO_BYTE_HI_nocast(IOTA_D_T): - if (LOC || !FOLD || !is_TRICKYFOLD_safe(p,RExC_end,UTF)) - goto normal_default; case '^': case '$': case '.': @@ -8604,11 +8877,6 @@ tryagain: switch ((U8)*++p) { /* These are all the special escapes. */ - case LATIN_SMALL_LETTER_SHARP_S: - case UTF8_TWO_BYTE_HI_nocast(LATIN_SMALL_LETTER_SHARP_S): - case UTF8_TWO_BYTE_HI_nocast(IOTA_D_T): - if (LOC || !FOLD || !is_TRICKYFOLD_safe(p,RExC_end,UTF)) - goto normal_default; case 'A': /* Start assertion */ case 'b': case 'B': /* Word-boundary assertion*/ case 'C': /* Single char !DANGEROUS! */ @@ -8735,7 +9003,7 @@ tryagain: goto recode_encoding; break; recode_encoding: - { + if (! RExC_override_recoding) { SV* enc = PL_encoding; ender = reg_recode((const char)(U8)ender, &enc); if (!enc && SIZE_ONLY) @@ -8779,55 +9047,205 @@ tryagain: * putting it in a special node keeps regexec from having to * deal with a non-utf8 multi-char fold */ if (FOLD - && (ender > 255 || (! MORE_ASCII_RESTRICTED && ! LOC)) - && is_TRICKYFOLD_cp(ender)) + && (ender > 255 || (! MORE_ASCII_RESTRICTED && ! LOC))) { - /* If is in middle of outputting characters into an - * EXACTish node, go output what we have so far, and - * position the parse so that this will be called again - * immediately */ - if (len) { - p = oldp; - goto loopdone; - } - else { + /* We look for either side of the fold. For example \xDF + * folds to 'ss'. We look for both the single character + * \xDF and the sequence 'ss'. When we find something that + * could be one of those, we stop and flush whatever we + * have output so far into the EXACTish node that was being + * built. Then restore the input pointer to what it was. + * regatom will return that EXACT node, and will be called + * again, positioned so the first character is the one in + * question, which we return in a different node type. + * The multi-char folds are a sequence, so the occurrence + * of the first character in that sequence doesn't + * necessarily mean that what follows is the rest of the + * sequence. We keep track of that with a state machine, + * with the state being set to the latest character + * processed before the current one. Most characters will + * set the state to 0, but if one occurs that is part of a + * potential tricky fold sequence, the state is set to that + * character, and the next loop iteration sees if the state + * should progress towards the final folded-from character, + * or if it was a false alarm. If it turns out to be a + * false alarm, the character(s) will be output in a new + * EXACTish node, and join_exact() will later combine them. + * In the case of the 'ss' sequence, which is more common + * and more easily checked, some look-ahead is done to + * save time by ruling-out some false alarms */ + switch (ender) { + default: + latest_char_state = generic_char; + break; + case 's': + case 'S': + case 0x17F: /* LATIN SMALL LETTER LONG S */ + if (AT_LEAST_UNI_SEMANTICS) { + if (latest_char_state == char_s) { /* 'ss' */ + ender = LATIN_SMALL_LETTER_SHARP_S; + goto do_tricky; + } + else if (p < RExC_end) { + + /* Look-ahead at the next character. If it + * is also an s, we handle as a sharp s + * tricky regnode. */ + if (*p == 's' || *p == 'S') { + + /* But first flush anything in the + * EXACTish buffer */ + if (len != 0) { + p = oldp; + goto loopdone; + } + p++; /* Account for swallowing this + 's' up */ + ender = LATIN_SMALL_LETTER_SHARP_S; + goto do_tricky; + } + /* Here, the next character is not a + * literal 's', but still could + * evaluate to one if part of a \o{}, + * \x or \OCTAL-DIGIT. The minimum + * length required for that is 4, eg + * \x53 or \123 */ + else if (*p == '\\' + && p < RExC_end - 4 + && (isDIGIT(*(p + 1)) + || *(p + 1) == 'x' + || *(p + 1) == 'o' )) + { + + /* Here, it could be an 's', too much + * bother to figure it out here. Flush + * the buffer if any; when come back + * here, set the state so know that the + * previous char was an 's' */ + if (len != 0) { + latest_char_state = generic_char; + p = oldp; + goto loopdone; + } + latest_char_state = char_s; + break; + } + } + } - /* Here we are ready to output our tricky fold - * character. What's done is to pretend it's in a - * [bracketed] class, and let the code that deals with - * those handle it, as that code has all the - * intelligence necessary. First save the current - * parse state, get rid of the already allocated EXACT - * node that the ANYOFV node will replace, and point - * the parse to a buffer which we fill with the - * character we want the regclass code to think is - * being parsed */ - char* const oldregxend = RExC_end; - char tmpbuf[2]; - RExC_emit = orig_emit; - RExC_parse = tmpbuf; - if (UTF) { - tmpbuf[0] = UTF8_TWO_BYTE_HI(ender); - tmpbuf[1] = UTF8_TWO_BYTE_LO(ender); - RExC_end = RExC_parse + 2; - } - else { - tmpbuf[0] = (char) ender; - RExC_end = RExC_parse + 1; - } + /* Here, can't be an 'ss' sequence, or at least not + * one that could fold to/from the sharp ss */ + latest_char_state = generic_char; + break; + case 0x03C5: /* First char in upsilon series */ + case 0x03A5: /* Also capital UPSILON, which folds to + 03C5, and hence exhibits the same + problem */ + if (p < RExC_end - 4) { /* Need >= 4 bytes left */ + latest_char_state = upsilon_1; + if (len != 0) { + p = oldp; + goto loopdone; + } + } + else { + latest_char_state = generic_char; + } + break; + case 0x03B9: /* First char in iota series */ + case 0x0399: /* Also capital IOTA */ + case 0x1FBE: /* GREEK PROSGEGRAMMENI folds to 3B9 */ + case 0x0345: /* COMBINING GREEK YPOGEGRAMMENI folds + to 3B9 */ + if (p < RExC_end - 4) { + latest_char_state = iota_1; + if (len != 0) { + p = oldp; + goto loopdone; + } + } + else { + latest_char_state = generic_char; + } + break; + case 0x0308: + if (latest_char_state == upsilon_1) { + latest_char_state = upsilon_2; + } + else if (latest_char_state == iota_1) { + latest_char_state = iota_2; + } + else { + latest_char_state = generic_char; + } + break; + case 0x301: + if (latest_char_state == upsilon_2) { + ender = GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS; + goto do_tricky; + } + else if (latest_char_state == iota_2) { + ender = GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS; + goto do_tricky; + } + latest_char_state = generic_char; + break; - ret = regclass(pRExC_state,depth+1); + /* These are the tricky fold characters. Flush any + * buffer first. (When adding to this list, also should + * add them to fold_grind.t to make sure get tested) */ + case GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS: + case GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS: + case LATIN_SMALL_LETTER_SHARP_S: + case LATIN_CAPITAL_LETTER_SHARP_S: + case 0x1FD3: /* GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA */ + case 0x1FE3: /* GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA */ + if (len != 0) { + p = oldp; + goto loopdone; + } + /* FALL THROUGH */ + do_tricky: { + char* const oldregxend = RExC_end; + U8 tmpbuf[UTF8_MAXBYTES+1]; + + /* Here, we know we need to generate a special + * regnode, and 'ender' contains the tricky + * character. What's done is to pretend it's in a + * [bracketed] class, and let the code that deals + * with those handle it, as that code has all the + * intelligence necessary. First save the current + * parse state, get rid of the already allocated + * but empty EXACT node that the ANYOFV node will + * replace, and point the parse to a buffer which + * we fill with the character we want the regclass + * code to think is being parsed */ + RExC_emit = orig_emit; + RExC_parse = (char *) tmpbuf; + if (UTF) { + U8 *d = uvchr_to_utf8(tmpbuf, ender); + *d = '\0'; + RExC_end = (char *) d; + } + else { /* ender above 255 already excluded */ + tmpbuf[0] = (U8) ender; + tmpbuf[1] = '\0'; + RExC_end = RExC_parse + 1; + } - /* Here, have parsed the buffer. Reset the parse to - * the actual input, and return */ - RExC_end = oldregxend; - RExC_parse = p - 1; + ret = regclass(pRExC_state,depth+1); + + /* Here, have parsed the buffer. Reset the parse to + * the actual input, and return */ + RExC_end = oldregxend; + RExC_parse = p - 1; - Set_Node_Offset(ret, RExC_parse); - Set_Node_Cur_Length(ret); - nextchar(pRExC_state); - *flagp |= HASWIDTH|SIMPLE; - return ret; + Set_Node_Offset(ret, RExC_parse); + Set_Node_Cur_Length(ret); + nextchar(pRExC_state); + *flagp |= HASWIDTH|SIMPLE; + return ret; + } } } @@ -8963,8 +9381,9 @@ tryagain: } len--; } - else + else { REGC((char)ender, s++); + } } loopdone: /* Jumped to when encounters something that shouldn't be in the node */ @@ -9185,7 +9604,7 @@ S_checkposixcc(pTHX_ RExC_state_t *pRExC_state) } } -/* No locale test, and always Unicode semantics */ +/* No locale test, and always Unicode semantics, no ignore-case differences */ #define _C_C_T_NOLOC_(NAME,TEST,WORD) \ ANYOF_##NAME: \ for (value = 0; value < 256; value++) \ @@ -9205,8 +9624,11 @@ case ANYOF_N##NAME: \ /* Like the above, but there are differences if we are in uni-8-bit or not, so * there are two tests passed in, to use depending on that. There aren't any * cases where the label is different from the name, so no need for that - * parameter */ -#define _C_C_T_(NAME, TEST_8, TEST_7, WORD) \ + * parameter. + * Sets 'what' to WORD which is the property name for non-bitmap code points; + * But, uses FOLD_WORD instead if /i has been selected, to allow a different + * property name */ +#define _C_C_T_(NAME, TEST_8, TEST_7, WORD, FOLD_WORD) \ ANYOF_##NAME: \ if (LOC) ANYOF_CLASS_SET(ret, ANYOF_##NAME); \ else if (UNI_SEMANTICS) { \ @@ -9223,7 +9645,12 @@ ANYOF_##NAME: \ } \ } \ yesno = '+'; \ - what = WORD; \ + if (FOLD) { \ + what = FOLD_WORD; \ + } \ + else { \ + what = WORD; \ + } \ break; \ case ANYOF_N##NAME: \ if (LOC) ANYOF_CLASS_SET(ret, ANYOF_N##NAME); \ @@ -9255,11 +9682,16 @@ case ANYOF_N##NAME: \ } \ } \ yesno = '!'; \ - what = WORD; \ + if (FOLD) { \ + what = FOLD_WORD; \ + } \ + else { \ + what = WORD; \ + } \ break STATIC U8 -S_set_regclass_bit_fold(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, HV** invlist_ptr, AV** alternate_ptr) +S_set_regclass_bit_fold(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, SV** invlist_ptr, AV** alternate_ptr) { /* Handle the setting of folds in the bitmap for non-locale ANYOF nodes. @@ -9344,6 +9776,8 @@ S_set_regclass_bit_fold(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); break; case LATIN_SMALL_LETTER_SHARP_S: + *invlist_ptr = add_cp_to_invlist(*invlist_ptr, + LATIN_CAPITAL_LETTER_SHARP_S); /* Under /a, /d, and /u, this can match the two chars "ss" */ if (! MORE_ASCII_RESTRICTED) { @@ -9360,21 +9794,17 @@ S_set_regclass_bit_fold(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 case 'I': case 'i': case 'L': case 'l': case 'T': case 't': - /* These all are targets of multi-character folds, which can - * occur with only non-Latin1 characters in the fold, so they - * can match if the target string isn't UTF-8 */ - ANYOF_FLAGS(node) |= ANYOF_NONBITMAP_NON_UTF8; - break; 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, which occur - * only with a non-Latin1 character as part of the fold, so - * they can't match unless the target string is in UTF-8, so no - * action here is necessary */ + /* 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 */ break; default: /* Use deprecated warning to increase the chances of this @@ -9401,7 +9831,7 @@ S_set_regclass_bit_fold(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 PERL_STATIC_INLINE U8 -S_set_regclass_bit(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, HV** invlist_ptr, AV** alternate_ptr) +S_set_regclass_bit(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, SV** invlist_ptr, AV** alternate_ptr) { /* This inline function sets a bit in the bitmap if not already set, and if * appropriate, its fold, returning the number of bits that actually @@ -9463,13 +9893,14 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth) IV namedclass; char *rangebegin = NULL; bool need_class = 0; + bool allow_full_fold = TRUE; /* Assume wants multi-char folding */ SV *listsv = NULL; STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more than just initialized. */ UV n; /* code points this node matches that can't be stored in the bitmap */ - HV* nonbitmap = NULL; + SV* nonbitmap = NULL; /* The items that are to match that aren't stored in the bitmap, but are a * result of things that are stored there. This is the fold closure of @@ -9485,7 +9916,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth) * that matches. A 2nd list is used so that the 'nonbitmap' list is kept * empty unless there is something whose fold we don't know about, and will * have to go out to the disk to find. */ - HV* l1_fold_invlist = NULL; + SV* l1_fold_invlist = NULL; /* List of multi-character folds that are matched by this node */ AV* unicode_alternate = NULL; @@ -9519,24 +9950,26 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth) RExC_parse++; if (!SIZE_ONLY) ANYOF_FLAGS(ret) |= ANYOF_INVERT; + + /* We have decided to not allow multi-char folds in inverted character + * classes, due to the confusion that can happen, especially with + * classes that are designed for a non-Unicode world: You have the + * peculiar case that: + "s s" =~ /^[^\xDF]+$/i => Y + "ss" =~ /^[^\xDF]+$/i => N + * + * See [perl #89750] */ + allow_full_fold = FALSE; } if (SIZE_ONLY) { RExC_size += ANYOF_SKIP; -#ifdef ANYOF_ADD_LOC_SKIP - if (LOC) { - RExC_size += ANYOF_ADD_LOC_SKIP; - } -#endif listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */ } else { RExC_emit += ANYOF_SKIP; if (LOC) { ANYOF_FLAGS(ret) |= ANYOF_LOCALE; -#ifdef ANYOF_ADD_LOC_SKIP - RExC_emit += ANYOF_ADD_LOC_SKIP; -#endif } ANYOF_BITMAP_ZERO(ret); listsv = newSVpvs("# comment\n"); @@ -9606,7 +10039,7 @@ parseit: from earlier versions, OTOH that behaviour was broken as well. */ UV v; /* value is register so we cant & it /grrr */ - if (reg_namedseq(pRExC_state, &v, NULL)) { + if (reg_namedseq(pRExC_state, &v, NULL, depth)) { goto parseit; } value= v; @@ -9731,7 +10164,7 @@ parseit: break; } recode_encoding: - { + if (! RExC_override_recoding) { SV* enc = PL_encoding; value = reg_recode((const char)(U8)value, &enc); if (!enc && SIZE_ONLY) @@ -9765,14 +10198,10 @@ parseit: if (LOC && namedclass < ANYOF_MAX && ! need_class) { need_class = 1; if (SIZE_ONLY) { -#ifdef ANYOF_CLASS_ADD_SKIP - RExC_size += ANYOF_CLASS_ADD_SKIP; -#endif + RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP; } else { -#ifdef ANYOF_CLASS_ADD_SKIP - RExC_emit += ANYOF_CLASS_ADD_SKIP; -#endif + RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP; ANYOF_CLASS_ZERO(ret); } ANYOF_FLAGS(ret) |= ANYOF_CLASS; @@ -9816,20 +10245,20 @@ parseit: * --jhi */ switch ((I32)namedclass) { - case _C_C_T_(ALNUMC, isALNUMC_L1, isALNUMC, "XPosixAlnum"); - case _C_C_T_(ALPHA, isALPHA_L1, isALPHA, "XPosixAlpha"); - case _C_C_T_(BLANK, isBLANK_L1, isBLANK, "XPosixBlank"); - case _C_C_T_(CNTRL, isCNTRL_L1, isCNTRL, "XPosixCntrl"); - case _C_C_T_(GRAPH, isGRAPH_L1, isGRAPH, "XPosixGraph"); - case _C_C_T_(LOWER, isLOWER_L1, isLOWER, "XPosixLower"); - case _C_C_T_(PRINT, isPRINT_L1, isPRINT, "XPosixPrint"); - case _C_C_T_(PSXSPC, isPSXSPC_L1, isPSXSPC, "XPosixSpace"); - case _C_C_T_(PUNCT, isPUNCT_L1, isPUNCT, "XPosixPunct"); - case _C_C_T_(UPPER, isUPPER_L1, isUPPER, "XPosixUpper"); + case _C_C_T_(ALNUMC, isALNUMC_L1, isALNUMC, "XPosixAlnum", "XPosixAlnum"); + case _C_C_T_(ALPHA, isALPHA_L1, isALPHA, "XPosixAlpha", "XPosixAlpha"); + case _C_C_T_(BLANK, isBLANK_L1, isBLANK, "XPosixBlank", "XPosixBlank"); + case _C_C_T_(CNTRL, isCNTRL_L1, isCNTRL, "XPosixCntrl", "XPosixCntrl"); + case _C_C_T_(GRAPH, isGRAPH_L1, isGRAPH, "XPosixGraph", "XPosixGraph"); + case _C_C_T_(LOWER, isLOWER_L1, isLOWER, "XPosixLower", "__XPosixLower_i"); + case _C_C_T_(PRINT, isPRINT_L1, isPRINT, "XPosixPrint", "XPosixPrint"); + case _C_C_T_(PSXSPC, isPSXSPC_L1, isPSXSPC, "XPosixSpace", "XPosixSpace"); + case _C_C_T_(PUNCT, isPUNCT_L1, isPUNCT, "XPosixPunct", "XPosixPunct"); + case _C_C_T_(UPPER, isUPPER_L1, isUPPER, "XPosixUpper", "__XPosixUpper_i"); /* \s, \w match all unicode if utf8. */ - case _C_C_T_(SPACE, isSPACE_L1, isSPACE, "SpacePerl"); - case _C_C_T_(ALNUM, isWORDCHAR_L1, isALNUM, "Word"); - case _C_C_T_(XDIGIT, isXDIGIT_L1, isXDIGIT, "XPosixXDigit"); + case _C_C_T_(SPACE, isSPACE_L1, isSPACE, "SpacePerl", "SpacePerl"); + case _C_C_T_(ALNUM, isWORDCHAR_L1, isALNUM, "Word", "Word"); + case _C_C_T_(XDIGIT, isXDIGIT_L1, isXDIGIT, "XPosixXDigit", "XPosixXDigit"); case _C_C_T_NOLOC_(VERTWS, is_VERTWS_latin1(&value), "VertSpace"); case _C_C_T_NOLOC_(HORIZWS, is_HORIZWS_latin1(&value), "HorizSpace"); case ANYOF_ASCII: @@ -9895,7 +10324,7 @@ parseit: } if (what && ! (AT_LEAST_ASCII_RESTRICTED)) { /* Strings such as "+utf8::isWord\n" */ - Perl_sv_catpvf(aTHX_ listsv, "%cutf8::Is%s\n", yesno, what); + Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s\n", yesno, what); } continue; @@ -9911,8 +10340,10 @@ parseit: } else { prevvalue = value; /* save the beginning of the range */ - if (*RExC_parse == '-' && RExC_parse+1 < RExC_end && - RExC_parse[1] != ']') { + if (RExC_parse+1 < RExC_end + && *RExC_parse == '-' + && RExC_parse[1] != ']') + { RExC_parse++; /* a bad range like \w-, [:word:]- ? */ @@ -9994,10 +10425,9 @@ parseit: /* If folding and there are code points above 255, we calculate all * characters that could fold to or from the ones already on the list */ if (FOLD && nonbitmap) { - UV i; + UV start, end; /* End points of code point ranges */ - HV* fold_intersection; - UV* fold_list; + SV* fold_intersection; /* This is a list of all the characters that participate in folds * (except marks, etc in multi-char folds */ @@ -10017,14 +10447,18 @@ parseit: * compilation of Perl itself before the Unicode tables are * generated) */ if (invlist_len(PL_utf8_foldable) == 0) { - PL_utf8_foldclosures = _new_invlist(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) { U8 dummy[UTF8_MAXBYTES+1]; STRLEN dummy_len; - to_utf8_fold((U8*) "A", dummy, &dummy_len); + + /* This particular string is above \xff in both UTF-8 and + * UTFEBCDIC */ + to_utf8_fold((U8*) "\xC8\x80", dummy, &dummy_len); + assert(PL_utf8_tofold); /* Verify that worked */ } PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold); } @@ -10034,30 +10468,21 @@ parseit: * be checked. Get the intersection of this class and all the * possible characters that are foldable. This can quickly narrow * down a large class */ - fold_intersection = invlist_intersection(PL_utf8_foldable, nonbitmap); + _invlist_intersection(PL_utf8_foldable, nonbitmap, &fold_intersection); /* Now look at the foldable characters in this class individually */ - fold_list = invlist_array(fold_intersection); - for (i = 0; i < invlist_len(fold_intersection); i++) { + invlist_iterinit(fold_intersection); + while (invlist_iternext(fold_intersection, &start, &end)) { UV j; - /* The next entry is the beginning of the range that is in the - * class */ - UV start = fold_list[i++]; - - - /* The next entry is the beginning of the next range, which - * isn't in the class, so the end of the current range is one - * less than that */ - UV end = fold_list[i] - 1; - /* Look at every character in the range */ for (j = start; j <= end; j++) { /* Get its fold */ U8 foldbuf[UTF8_MAXBYTES_CASE+1]; STRLEN foldlen; - const UV f = to_uni_fold(j, foldbuf, &foldlen); + const UV f = + _to_uni_fold_flags(j, foldbuf, &foldlen, allow_full_fold); if (foldlen > (STRLEN)UNISKIP(f)) { @@ -10106,6 +10531,18 @@ parseit: add_alternate(&unicode_alternate, foldbuf, foldlen); end_multi_fold: ; } + + /* This is special-cased, as it is the only letter which + * has both a multi-fold and single-fold in Latin1. All + * the other chars that have single and multi-folds are + * always in utf8, and the utf8 folding algorithm catches + * them */ + if (! LOC && j == LATIN_CAPITAL_LETTER_SHARP_S) { + stored += set_regclass_bit(pRExC_state, + ret, + LATIN_SMALL_LETTER_SHARP_S, + &l1_fold_invlist, &unicode_alternate); + } } else { /* Single character fold. Add everything in its fold @@ -10159,13 +10596,14 @@ parseit: } } } - invlist_destroy(fold_intersection); + SvREFCNT_dec(fold_intersection); } /* Combine the two lists into one. */ if (l1_fold_invlist) { if (nonbitmap) { - nonbitmap = invlist_union(nonbitmap, l1_fold_invlist); + _invlist_union(nonbitmap, l1_fold_invlist, &nonbitmap); + SvREFCNT_dec(l1_fold_invlist); } else { nonbitmap = l1_fold_invlist; @@ -10183,18 +10621,45 @@ parseit: * nothing like \w in it; some thought also would have to be given to the * interaction with above 0x100 chars */ if (! LOC - && (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT + && (ANYOF_FLAGS(ret) & ANYOF_INVERT) && ! unicode_alternate - && ! nonbitmap + /* In case of /d, there are some things that should match only when in + * not in the bitmap, i.e., they require UTF8 to match. These are + * listed in nonbitmap. */ + && (! nonbitmap + || ! DEPENDS_SEMANTICS + || (ANYOF_FLAGS(ret) & ANYOF_NONBITMAP_NON_UTF8)) && SvCUR(listsv) == initial_listsv_len) { - for (value = 0; value < ANYOF_BITMAP_SIZE; ++value) - ANYOF_BITMAP(ret)[value] ^= 0xFF; + if (! nonbitmap) { + for (value = 0; value < ANYOF_BITMAP_SIZE; ++value) + ANYOF_BITMAP(ret)[value] ^= 0xFF; + /* The inversion means that everything above 255 is matched */ + ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL; + } + else { + /* Here, also has things outside the bitmap. Go through each bit + * individually and add it to the list to get rid of from those + * things not in the bitmap */ + SV *remove_list = _new_invlist(2); + _invlist_invert(nonbitmap); + for (value = 0; value < 256; ++value) { + if (ANYOF_BITMAP_TEST(ret, value)) { + ANYOF_BITMAP_CLEAR(ret, value); + remove_list = add_cp_to_invlist(remove_list, value); + } + else { + ANYOF_BITMAP_SET(ret, value); + } + } + _invlist_subtract(nonbitmap, remove_list, &nonbitmap); + SvREFCNT_dec(remove_list); + } + stored = 256 - stored; - /* The inversion means that everything above 255 is matched; and at the - * same time we clear the invert flag */ - ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL; + /* Clear the invert flag since have just done it here */ + ANYOF_FLAGS(ret) &= ~ANYOF_INVERT; } /* Folding in the bitmap is taken care of above, but not for locale (for @@ -10258,17 +10723,24 @@ parseit: else { op = EXACT; } - } /* else 2 chars in the bit map: the folds of each other */ - else if (AT_LEAST_UNI_SEMANTICS || !isASCII(value)) { - - /* To join adjacent nodes, they must be the exact EXACTish type. - * Try to use the most likely type, by using EXACTFU if the regex - * calls for them, or is required because the character is - * non-ASCII */ - op = EXACTFU; } - else { /* Otherwise, more likely to be EXACTF type */ - op = EXACTF; + else { /* else 2 chars in the bit map: the folds of each other */ + + /* Use the folded value, which for the cases where we get here, + * is just the lower case of the current one (which may resolve to + * itself, or to the other one */ + value = toLOWER_LATIN1(value); + if (AT_LEAST_UNI_SEMANTICS || !isASCII(value)) { + + /* To join adjacent nodes, they must be the exact EXACTish + * type. Try to use the most likely type, by using EXACTFU if + * the regex calls for them, or is required because the + * character is non-ASCII */ + op = EXACTFU; + } + else { /* Otherwise, more likely to be EXACTF type */ + op = EXACTF; + } } ret = reg_node(pRExC_state, op); @@ -10289,33 +10761,9 @@ parseit: } if (nonbitmap) { - UV* nonbitmap_array = invlist_array(nonbitmap); - UV nonbitmap_len = invlist_len(nonbitmap); - UV i; - - /* Here have the full list of items to match that aren't in the - * bitmap. Convert to the structure that the rest of the code is - * expecting. XXX That rest of the code should convert to this - * structure */ - for (i = 0; i < nonbitmap_len; i++) { - - /* The next entry is the beginning of the range that is in the - * class */ - UV start = nonbitmap_array[i++]; - UV end; - - /* The next entry is the beginning of the next range, which isn't - * in the class, so the end of the current range is one less than - * that. But if there is no next range, it means that the range - * begun by 'start' extends to infinity, which for this platform - * ends at UV_MAX */ - if (i == nonbitmap_len) { - end = UV_MAX; - } - else { - end = nonbitmap_array[i] - 1; - } - + UV start, end; + invlist_iterinit(nonbitmap); + while (invlist_iternext(nonbitmap, &start, &end)) { if (start == end) { Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", start); } @@ -10326,7 +10774,7 @@ parseit: start, end); } } - invlist_destroy(nonbitmap); + SvREFCNT_dec(nonbitmap); } if (SvCUR(listsv) == initial_listsv_len && ! unicode_alternate) { @@ -10346,10 +10794,18 @@ parseit: * used later (regexec.c:S_reginclass()). */ av_store(av, 0, listsv); av_store(av, 1, NULL); - av_store(av, 2, MUTABLE_SV(unicode_alternate)); - if (unicode_alternate) { /* This node is variable length */ - OP(ret) = ANYOFV; - } + + /* Store any computed multi-char folds only if we are allowing + * them */ + if (allow_full_fold) { + av_store(av, 2, MUTABLE_SV(unicode_alternate)); + if (unicode_alternate) { /* This node is variable length */ + OP(ret) = ANYOFV; + } + } + else { + av_store(av, 2, NULL); + } rv = newRV_noinc(MUTABLE_SV(av)); n = add_data(pRExC_state, 1, "s"); RExC_rxi->data->data[n] = (void*)rv; @@ -11621,12 +12077,11 @@ Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param) dVAR; struct regexp *const r = (struct regexp *)SvANY(rx); regexp_internal *reti; - int len, npar; + int len; RXi_GET_DECL(r,ri); PERL_ARGS_ASSERT_REGDUPE_INTERNAL; - npar = r->nparens+1; len = ProgLen(ri); Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);