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