refhash.t revision 1.1.1.1 
1#!/usr/bin/perl -T -w
2# 
3# Basic test suite for Tie::RefHash and Tie::RefHash::Nestable.
4# 
5# The testing is in two parts: first, run lots of tests on both a tied
6# hash and an ordinary un-tied hash, and check they give the same
7# answer.  Then there are tests for those cases where the tied hashes
8# should behave differently to normal hashes, that is, when using
9# references as keys.
10# 
11
12BEGIN {
13    if( $ENV{PERL_CORE} ) {
14        chdir 't';
15        @INC = '../lib';
16    }
17}
18
19BEGIN {
20  unless ( eval { require Data::Dumper; 1 } ) {
21    print "1..0 # Skip -- Data::Dumper is not available\n";
22    exit 0;
23  }
24}    
25
26use strict;
27use Tie::RefHash;
28use Data::Dumper;
29my $numtests = 39;
30my $currtest = 1;
31print "1..$numtests\n";
32
33my $ref = []; my $ref1 = [];
34
35package Boustrophedon; # A class with overloaded "".
36sub new { my ($c, $s) = @_; bless \$s, $c }
37use overload '""' => sub { ${$_[0]} . reverse ${$_[0]} };
38package main;
39my $ox = Boustrophedon->new("foobar");
40
41# Test standard hash functionality, by performing the same operations
42# on a tied hash and on a normal hash, and checking that the results
43# are the same.  This does of course assume that Perl hashes are not
44# buggy :-)
45# 
46my @tests = standard_hash_tests();
47
48my @ordinary_results = runtests(\@tests, undef);
49foreach my $class ('Tie::RefHash', 'Tie::RefHash::Nestable') {
50    my @tied_results = runtests(\@tests, $class);
51    my $all_ok = 1;
52
53    die if @ordinary_results != @tied_results;
54    foreach my $i (0 .. $#ordinary_results) {
55        my ($or, $ow, $oe) = @{$ordinary_results[$i]};
56        my ($tr, $tw, $te) = @{$tied_results[$i]};
57        
58        my $ok = 1;
59        local $^W = 0;
60        $ok = 0 if (defined($or) != defined($tr)) or ($or ne $tr);
61        $ok = 0 if (defined($ow) != defined($tw)) or ($ow ne $tw);
62        $ok = 0 if (defined($oe) != defined($te)) or ($oe ne $te);
63        
64        if (not $ok) {
65            print STDERR
66              "failed for $class: $tests[$i]\n",
67              "ordinary hash gave:\n",
68              defined $or ? "\tresult:    $or\n" : "\tundef result\n",
69              defined $ow ? "\twarning:   $ow\n" : "\tno warning\n",
70              defined $oe ? "\texception: $oe\n" : "\tno exception\n",
71              "tied $class hash gave:\n",
72              defined $tr ? "\tresult:    $tr\n" : "\tundef result\n",
73              defined $tw ? "\twarning:   $tw\n" : "\tno warning\n",
74              defined $te ? "\texception: $te\n" : "\tno exception\n",
75              "\n";
76            $all_ok = 0;
77        }
78    }
79    test($all_ok);
80}
81
82# Now test Tie::RefHash's special powers
83my (%h, $h);
84$h = eval { tie %h, 'Tie::RefHash' };
85warn $@ if $@;
86test(not $@);
87test(ref($h) eq 'Tie::RefHash');
88test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash/);
89$h{$ref} = 'cholet';
90test($h{$ref} eq 'cholet');
91test(exists $h{$ref});
92test((keys %h) == 1);
93test(ref((keys %h)[0]) eq 'ARRAY');
94test((keys %h)[0] eq $ref);
95test((values %h) == 1);
96test((values %h)[0] eq 'cholet');
97my $count = 0;
98while (my ($k, $v) = each %h) {
99    if ($count++ == 0) {
100        test(ref($k) eq 'ARRAY');
101        test($k eq $ref);
102    }
103}
104test($count == 1);
105delete $h{$ref};
106test(not defined $h{$ref});
107test(not exists($h{$ref}));
108test((keys %h) == 0);
109test((values %h) == 0);
110$h{$ox} = "bellow"; # overloaded ""
111test(exists $h{$ox});
112test($h{$ox} eq "bellow");
113test(not exists $h{"foobarraboof"});
114undef $h;
115untie %h;
116
117# And now Tie::RefHash::Nestable's differences from Tie::RefHash.
118$h = eval { tie %h, 'Tie::RefHash::Nestable' };
119warn $@ if $@;
120test(not $@);
121test(ref($h) eq 'Tie::RefHash::Nestable');
122test(defined(tied(%h)) and tied(%h) =~ /^Tie::RefHash::Nestable/);
123$h{$ref}->{$ref1} = 'bungo';
124test($h{$ref}->{$ref1} eq 'bungo');
125
126# Test that the nested hash is also tied (for current implementation)
127test(defined(tied(%{$h{$ref}}))
128     and tied(%{$h{$ref}}) =~ /^Tie::RefHash::Nestable=/ );
129
130test((keys %h) == 1);
131test((keys %h)[0] eq $ref);
132test((keys %{$h{$ref}}) == 1);
133test((keys %{$h{$ref}})[0] eq $ref1);
134
135{
136    # Tests that delete returns the deleted element [perl #32193]
137    my $ref = \(my $var = "oink");
138    tie my %oink, 'Tie::RefHash';
139    $oink{$ref} = "ding";
140    test($oink{$ref} eq "ding");
141    test(delete($oink{$ref}) eq "ding");
142}
143
144die "expected to run $numtests tests, but ran ", $currtest - 1
145  if $currtest - 1 != $numtests;
146
147@tests = ();
148undef $ref;
149undef $ref1;
150
151exit();
152
153
154# Print 'ok X' if true, 'not ok X' if false
155# Uses global $currtest.
156# 
157sub test {
158    my $t = shift;
159    print 'not ' if not $t;
160    print 'ok ', $currtest++, "\n";
161}
162
163
164# Wrapper for Data::Dumper to 'dump' a scalar as an EXPR string. 
165sub dumped {
166    my $s = shift;
167    my $d = Dumper($s);
168    $d =~ s/^\$VAR1 =\s*//;
169    $d =~ s/;$//;
170    chomp $d;
171    return $d;
172}
173
174# Crudely dump a hash into a canonical string representation (because
175# hash keys can appear in any order, Data::Dumper may give different
176# strings for the same hash).
177# 
178sub dumph {
179    my $h = shift;
180    my $r = '';
181    foreach (sort keys %$h) {
182        $r = dumped($_) . ' => ' . dumped($h->{$_}) . "\n";
183    }
184    return $r;
185}
186
187# Run the tests and give results.
188# 
189# Parameters: reference to list of tests to run
190#             name of class to use for tied hash, or undef if not tied
191# 
192# Returns: list of [R, W, E] tuples, one for each test.
193# R is the return value from running the test, W any warnings it gave,
194# and E any exception raised with 'die'.  E and W will be tidied up a
195# little to remove irrelevant details like line numbers :-)
196# 
197# Will also run a few of its own 'ok N' tests.
198# 
199sub runtests {
200    my ($tests, $class) = @_;
201    my @r;
202
203    my (%h, $h);
204    if (defined $class) {
205        $h = eval { tie %h, $class };
206        warn $@ if $@;
207        test(not $@);
208        test(ref($h) eq $class);
209        test(defined(tied(%h)) and tied(%h) =~ /^\Q$class\E/);
210    }
211
212    foreach (@$tests) {
213        my ($result, $warning, $exception);
214        local $SIG{__WARN__} = sub { $warning .= $_[0] };
215        $result = scalar(eval $_);
216        if ($@)
217         {
218          die "$@:$_" unless defined $class;
219          $exception = $@;
220         }
221
222        foreach ($warning, $exception) {
223            next if not defined;
224            s/ at .+ line \d+\.$//mg;
225            s/ at .+ line \d+, at .*//mg;
226            s/ at .+ line \d+, near .*//mg;
227      s/(uninitialized value)( within)? [\$@%].*? in /$1 in /g;
228        }
229
230        my (@warnings, %seen);
231        foreach (split /\n/, $warning) {
232            push @warnings, $_ unless $seen{$_}++;
233        }
234        $warning = join("\n", @warnings);
235
236        push @r, [ $result, $warning, $exception ];
237    }
238
239    return @r;
240}
241
242
243# Things that should work just the same for an ordinary hash and a
244# Tie::RefHash.
245# 
246# Each test is a code string to be eval'd, it should do something with
247# %h and give a scalar return value.  The global $ref and $ref1 may
248# also be used.
249# 
250# One thing we don't test is that the ordering from 'keys', 'values'
251# and 'each' is the same.  You can't reasonably expect that.
252# 
253sub standard_hash_tests {
254    my @r;
255
256    # Library of standard tests on keys, values and each
257    my $STD_TESTS = <<'END'
258    join $;, sort keys %h;
259    join $;, sort values %h;
260    { my ($v, %tmp); $tmp{$v}++ while (defined($v = each %h)); dumph(\%tmp) }
261    { my ($k, $v, %tmp); $tmp{"$k$;$v"}++ while (($k, $v) = each %h); dumph(\%tmp) }
262END
263  ;
264    
265    # Tests on the existence of the element 'foo'
266    my $FOO_TESTS = <<'END'
267    defined $h{foo};
268    exists $h{foo};
269    $h{foo};    
270END
271  ;
272
273    # Test storing and deleting 'foo'
274    push @r, split /\n/, <<"END"
275    $STD_TESTS;
276    $FOO_TESTS;
277    \$h{foo} = undef;
278    $STD_TESTS;
279    $FOO_TESTS;
280    \$h{foo} = 'hello';
281    $STD_TESTS;
282    $FOO_TESTS;
283    delete  \$h{foo};
284    $STD_TESTS;
285    $FOO_TESTS;
286END
287  ;
288
289    # Test storing and removing under ordinary keys
290    my @things = ('boink', 0, 1, '', undef);
291    foreach my $key (map { dumped($_) } @things) {
292        foreach my $value ((map { dumped($_) } @things), '$ref') {
293            push @r, split /\n/, <<"END"
294            \$h{$key} = $value;
295            $STD_TESTS;
296            defined \$h{$key};
297            exists \$h{$key};
298            \$h{$key};
299            delete \$h{$key};
300            $STD_TESTS;
301            defined \$h{$key};
302            exists \$h{$key};
303            \$h{$key};
304END
305  ;
306        }
307    }
308    
309    # Test hash slices
310    my @slicetests;
311    @slicetests = split /\n/, <<'END'
312    @h{'b'} = ();
313    @h{'c'} = ('d');
314    @h{'e'} = ('f', 'g');
315    @h{'h', 'i'} = ();
316    @h{'j', 'k'} = ('l');
317    @h{'m', 'n'} = ('o', 'p');
318    @h{'q', 'r'} = ('s', 't', 'u');
319END
320  ;
321    my @aaa = @slicetests;
322    foreach (@slicetests) {
323        push @r, $_;
324        push @r, split(/\n/, $STD_TESTS);
325    }
326
327    # Test CLEAR
328    push @r, '%h = ();', split(/\n/, $STD_TESTS);
329
330    return @r;
331}
332