diff options
author | Karl Williamson <public@khwilliamson.com> | 2010-10-30 09:43:50 -0600 |
---|---|---|
committer | Father Chrysostomos <sprout@cpan.org> | 2010-10-31 06:11:41 -0700 |
commit | 45e32b91012d25c005eeed1854b16d65b27931cb (patch) | |
tree | 8867a76d1e9f73583471d95ab7539ee1769124be /lib/unicore | |
parent | 8eb023a9cc1ea46c4dc9b9bb6dd651817ac32889 (diff) | |
download | perl-45e32b91012d25c005eeed1854b16d65b27931cb.tar.gz |
mktables: Add tests for wrong equivalence attempts
mktables allows for multiple tables to be made equivalent, which in Unix
terminology means that they are essentially symbolic links. However
this should happen only when they have the same code points in them to
begin with. This adds a little more error checking.
Diffstat (limited to 'lib/unicore')
-rw-r--r-- | lib/unicore/mktables | 21 |
1 files changed, 15 insertions, 6 deletions
diff --git a/lib/unicore/mktables b/lib/unicore/mktables index b7cda6457c..b13fe0e09a 100644 --- a/lib/unicore/mktables +++ b/lib/unicore/mktables @@ -6560,12 +6560,21 @@ sub trace { return main::trace(@_); } my $addr = do { no overloading; pack 'J', $self; }; my $current_leader = ($related) ? $parent{$addr} : $leader{$addr}; - if ($related && - ! $other->perl_extension - && ! $current_leader->perl_extension) - { - Carp::my_carp_bug("set_equivalent_to should have 'Related => 0 for equivalencing two Unicode properties. Assuming $self is not related to $other"); - $related = 0; + if ($related) { + if ($current_leader->perl_extension) { + if ($other->perl_extension) { + Carp::my_carp_bug("Use add_alias() to set two Perl tables '$self' and '$other', equivalent."); + return; + } + } elsif (! $other->perl_extension) { + Carp::my_carp_bug("set_equivalent_to should have 'Related => 0 for equivalencing two Unicode properties. Assuming $self is not related to $other"); + $related = 0; + } + } + + if (! $self->is_empty && ! $self->matches_identically_to($other)) { + Carp::my_carp_bug("$self should be empty or match identically to $other. Not setting equivalent"); + return; } my $leader = do { no overloading; pack 'J', $current_leader; }; |