source: trunk/essentials/dev-lang/perl/lib/Tie/RefHash.t

#!/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';
    require Config;
    if (($Config::Config{'extensions'} !~ m!\bData/Dumper\b!) ){
        print "1..0 # Skip -- Perl configured without Data::Dumper module\n";
        exit 0;
    }
}    

use strict;
use Tie::RefHash;
use Data::Dumper;
my $numtests = 39;
my $currtest = 1;
print "1..$numtests\n";

my $ref = []; my $ref1 = [];

package Boustrophedon; # A class with overloaded "".
sub new { my ($c, $s) = @_; bless \$s, $c }
use overload '""' => sub { ${$_[0]} . reverse ${$_[0]} };
package main;
my $ox = Boustrophedon->new("foobar");

# 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);
$h = eval { 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);
$h{$ox} = "bellow"; # overloaded ""
test(exists $h{$ox});
test($h{$ox} eq "bellow");
test(not exists $h{"foobarraboof"});
undef $h;
untie %h;

# And now Tie::RefHash::Nestable's differences from Tie::RefHash.
$h = eval { 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);

{
    # Tests that delete returns the deleted element [perl #32193]
    my $ref = \(my $var = "oink");
    tie my %oink, 'Tie::RefHash';
    $oink{$ref} = "ding";
    test($oink{$ref} eq "ding");
    test(delete($oink{$ref}) eq "ding");
}

die "expected to run $numtests tests, but ran ", $currtest - 1
  if $currtest - 1 != $numtests;

@tests = ();
undef $ref;
undef $ref1;

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.
#