diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | lib/Tie/RefHash.pm | 42 | ||||
| -rw-r--r-- | t/lib/tie-refhash.t | 297 |
3 files changed, 337 insertions, 3 deletions
@@ -1447,6 +1447,7 @@ t/lib/texttabs.t See if Text::Tabs works t/lib/textwrap.t See if Text::Wrap::wrap works t/lib/thr5005.t Test 5.005-style threading (skipped if no use5005threads) t/lib/tie-push.t Test for Tie::Array +t/lib/tie-refhash.t Test for Tie::RefHash and Tie::RefHash::Nestable t/lib/tie-splice.t Test for Tie::Array::SPLICE t/lib/tie-stdarray.t Test for Tie::StdArray t/lib/tie-stdhandle.t Test for Tie::StdHandle diff --git a/lib/Tie/RefHash.pm b/lib/Tie/RefHash.pm index ffa9eb20a0..d4111d92e5 100644 --- a/lib/Tie/RefHash.pm +++ b/lib/Tie/RefHash.pm @@ -9,17 +9,26 @@ Tie::RefHash - use references as hash keys require 5.004; use Tie::RefHash; tie HASHVARIABLE, 'Tie::RefHash', LIST; + tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST; untie HASHVARIABLE; =head1 DESCRIPTION -This module provides the ability to use references as hash keys if -you first C<tie> the hash variable to this module. +This module provides the ability to use references as hash keys if you +first C<tie> the hash variable to this module. Normally, only the +keys of the tied hash itself are preserved as references; to use +references as keys in hashes-of-hashes, use Tie::RefHash::Nestable, +included as part of Tie::Hash. It is implemented using the standard perl TIEHASH interface. Please see the C<tie> entry in perlfunc(1) and perltie(1) for more information. +The Nestable version works by looking for hash references being stored +and converting them to tied hashes so that they too can have +references as keys. This will happen without warning whenever you +store a reference to one of your own hashes in the tied hash. + =head1 EXAMPLE use Tie::RefHash; @@ -36,6 +45,11 @@ see the C<tie> entry in perlfunc(1) and perltie(1) for more information. print ref($_), "\n"; } + tie %h, 'Tie::RefHash::Nestable'; + $h{$a}->{$b} = 1; + for (keys %h, keys %{$h{$a}}) { + print ref($_), "\n"; + } =head1 AUTHOR @@ -68,7 +82,17 @@ sub TIEHASH { sub FETCH { my($s, $k) = @_; - (ref $k) ? $s->[0]{"$k"}[1] : $s->[1]{$k}; + if (ref $k) { + if (defined $s->[0]{"$k"}) { + $s->[0]{"$k"}[1]; + } + else { + undef; + } + } + else { + $s->[1]{$k}; + } } sub STORE { @@ -121,4 +145,16 @@ sub CLEAR { %{$s->[1]} = (); } +package Tie::RefHash::Nestable; +use vars '@ISA'; @ISA = qw(Tie::RefHash); + +sub STORE { + my($s, $k, $v) = @_; + if (ref($v) eq 'HASH' and not tied %$v) { + my @elems = %$v; + tie %$v, ref($s), @elems; + } + $s->SUPER::STORE($k, $v); +} + 1; diff --git a/t/lib/tie-refhash.t b/t/lib/tie-refhash.t new file mode 100644 index 0000000000..7ad2bebd1d --- /dev/null +++ b/t/lib/tie-refhash.t @@ -0,0 +1,297 @@ +#!/usr/bin/perl -w +# +# Basic test suite for Tie::RefHash and Tie::RefHash::Nestable. +# +# The testing is in two parts: first, run lots of tests on both a tied +# hash and an ordinary un-tied hash, and check they give the same +# answer. Then there are tests for those cases where the tied hashes +# should behave differently to normal hashes, that is, when using +# references as keys. +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '.'; + push @INC, '../lib'; +} + +use strict; +use Tie::RefHash; +use Data::Dumper; +my $numtests = 34; +my $currtest = 1; +print "1..$numtests\n"; + +my $ref = []; my $ref1 = []; + +# Test standard hash functionality, by performing the same operations +# on a tied hash and on a normal hash, and checking that the results +# are the same. This does of course assume that Perl hashes are not +# buggy :-) +# +my @tests = standard_hash_tests(); +my @ordinary_results = runtests(\@tests, undef); +foreach my $class ('Tie::RefHash', 'Tie::RefHash::Nestable') { + my @tied_results = runtests(\@tests, $class); + my $all_ok = 1; + + die if @ordinary_results != @tied_results; + foreach my $i (0 .. $#ordinary_results) { + my ($or, $ow, $oe) = @{$ordinary_results[$i]}; + my ($tr, $tw, $te) = @{$tied_results[$i]}; + + my $ok = 1; + local $^W = 0; + $ok = 0 if (defined($or) != defined($tr)) or ($or ne $tr); + $ok = 0 if (defined($ow) != defined($tw)) or ($ow ne $tw); + $ok = 0 if (defined($oe) != defined($te)) or ($oe ne $te); + + if (not $ok) { + print STDERR + "failed for $class: $tests[$i]\n", + "ordinary hash gave:\n", + defined $or ? "\tresult: $or\n" : "\tundef result\n", + defined $ow ? "\twarning: $ow\n" : "\tno warning\n", + defined $oe ? "\texception: $oe\n" : "\tno exception\n", + "tied $class hash gave:\n", + defined $tr ? "\tresult: $tr\n" : "\tundef result\n", + defined $tw ? "\twarning: $tw\n" : "\tno warning\n", + defined $te ? "\texception: $te\n" : "\tno exception\n", + "\n"; + $all_ok = 0; + } + } + test($all_ok); +} + +# Now test Tie::RefHash's special powers +my (%h, $h); +eval { $h = tie %h, 'Tie::RefHash' }; +warn $@ if $@; +test(not $@); +test(ref($h) eq 'Tie::RefHash'); +test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash/); +$h{$ref} = 'cholet'; +test($h{$ref} eq 'cholet'); +test(exists $h{$ref}); +test((keys %h) == 1); +test(ref((keys %h)[0]) eq 'ARRAY'); +test((keys %h)[0] eq $ref); +test((values %h) == 1); +test((values %h)[0] eq 'cholet'); +my $count = 0; +while (my ($k, $v) = each %h) { + if ($count++ == 0) { + test(ref($k) eq 'ARRAY'); + test($k eq $ref); + } +} +test($count == 1); +delete $h{$ref}; +test(not defined $h{$ref}); +test(not exists($h{$ref})); +test((keys %h) == 0); +test((values %h) == 0); +undef $h; +untie %h; + +# And now Tie::RefHash::Nestable's differences from Tie::RefHash. +eval { $h = tie %h, 'Tie::RefHash::Nestable' }; +warn $@ if $@; +test(not $@); +test(ref($h) eq 'Tie::RefHash::Nestable'); +test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash::Nestable/); +$h{$ref}->{$ref1} = 'bungo'; +test($h{$ref}->{$ref1} eq 'bungo'); + +# Test that the nested hash is also tied (for current implementation) +test(defined(tied(%{$h{$ref}})) + and tied(%{$h{$ref}}) =~ /^Tie::RefHash::Nestable=/ ); + +test((keys %h) == 1); +test((keys %h)[0] eq $ref); +test((keys %{$h{$ref}}) == 1); +test((keys %{$h{$ref}})[0] eq $ref1); + +die "expected to run $numtests tests, but ran ", $currtest - 1 + if $currtest - 1 != $numtests; +exit(); + + +# Print 'ok X' if true, 'not ok X' if false +# Uses global $currtest. +# +sub test { + my $t = shift; + print 'not ' if not $t; + print 'ok ', $currtest++, "\n"; +} + + +# Wrapper for Data::Dumper to 'dump' a scalar as an EXPR string. +sub dumped { + my $s = shift; + my $d = Dumper($s); + $d =~ s/^\$VAR1 =\s*//; + $d =~ s/;$//; + chomp $d; + return $d; +} + +# Crudely dump a hash into a canonical string representation (because +# hash keys can appear in any order, Data::Dumper may give different +# strings for the same hash). +# +sub dumph { + my $h = shift; + my $r = ''; + foreach (sort keys %$h) { + $r = dumped($_) . ' => ' . dumped($h->{$_}) . "\n"; + } + return $r; +} + +# Run the tests and give results. +# +# Parameters: reference to list of tests to run +# name of class to use for tied hash, or undef if not tied +# +# Returns: list of [R, W, E] tuples, one for each test. +# R is the return value from running the test, W any warnings it gave, +# and E any exception raised with 'die'. E and W will be tidied up a +# little to remove irrelevant details like line numbers :-) +# +# Will also run a few of its own 'ok N' tests. +# +sub runtests { + my ($tests, $class) = @_; + my @r; + + my (%h, $h); + if (defined $class) { + eval { $h = tie %h, $class }; + warn $@ if $@; + test(not $@); + test(ref($h) eq $class); + test(defined(tied(%h)) and tied(%h) =~ /^\Q$class\E/); + } + + foreach (@$tests) { + my ($result, $warning, $exception); + local $SIG{__WARN__} = sub { $warning .= $_[0] }; + $result = scalar(eval $_); + $exception = $@ if $@; + + foreach ($warning, $exception) { + next if not defined; + s/ at .+ line \d+\.$//mg; + s/ at .+ line \d+, at .*//mg; + s/ at .+ line \d+, near .*//mg; + } + + my (@warnings, %seen); + foreach (split /\n/, $warning) { + push @warnings, $_ unless $seen{$_}++; + } + $warning = join("\n", @warnings); + + push @r, [ $result, $warning, $exception ]; + } + + return @r; +} + + +# Things that should work just the same for an ordinary hash and a +# Tie::RefHash. +# +# Each test is a code string to be eval'd, it should do something with +# %h and give a scalar return value. The global $ref and $ref1 may +# also be used. +# +# One thing we don't test is that the ordering from 'keys', 'values' +# and 'each' is the same. You can't reasonably expect that. +# +sub standard_hash_tests { + my @r; + + # Library of standard tests on keys, values and each + my $STD_TESTS = <<'END' + join $;, sort keys %h; + join $;, sort values %h; + { my ($v, %tmp); %tmp{$v}++ while (defined($v = each %h)); dumph(\%tmp) } + { my ($k, $v, %tmp); $tmp{"$k$;$v"}++ while (($k, $v) = each %h); dumph(\%t +mp) } +END + ; + + # Tests on the existence of the element 'foo' + my $FOO_TESTS = <<'END' + defined $h{foo}; + exists $h{foo}; + $h{foo}; +END + ; + + # Test storing and deleting 'foo' + push @r, split /\n/, <<"END" + $STD_TESTS; + $FOO_TESTS; + \$h{foo} = undef; + $STD_TESTS; + $FOO_TESTS; + \$h{foo} = 'hello'; + $STD_TESTS; + $FOO_TESTS; + delete \$h{foo}; + $STD_TESTS; + $FOO_TESTS; +END + ; + + # Test storing and removing under ordinary keys + my @things = ('boink', 0, 1, '', undef); + foreach my $key (map { dumped($_) } @things) { + foreach my $value ((map { dumped($_) } @things), '$ref') { + push @r, split /\n/, <<"END" + \$h{$key} = $value; + $STD_TESTS; + defined \$h{$key}; + exists \$h{$key}; + \$h{$key}; + delete \$h{$key}; + $STD_TESTS; + defined \$h{$key}; + exists \$h{$key}; + \$h{$key}; +END + ; + } + } + + # Test hash slices + my @slicetests; + @slicetests = split /\n/, <<'END' + @h{} = (); + @h{} = ('a'); + @h{'b'} = (); + @h{'c'} = ('d'); + @h{'e'} = ('f', 'g'); + @h{'h', 'i'} = (); + @h{'j', 'k'} = ('l'); + @h{'m', 'n'} = ('o', 'p'); + @h{'q', 'r'} = ('s', 't', 'u'); +END + ; + my @aaa = @slicetests; + foreach (@slicetests) { + push @r, $_; + push @r, split(/\n/, $STD_TESTS); + } + + # Test CLEAR + push @r, 'clear %h', split(/\n/, $STD_TESTS); + + return @r; +} + |