[p5sagit/p5-mst-13.2.git] / 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.
# 
sub runtests {
    my ($tests, $class) = @_;
    my @r;

    my (%h, $h);
    if (defined $class) {
        $h = eval { 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 $_);
        if ($@)
         {
          die "$@:$_" unless defined $class;
          $exception = $@;
         }

        foreach ($warning, $exception) {
            next if not defined;
            s/ at .+ line \d+\.$//mg;
            s/ at .+ line \d+, at .*//mg;
            s/ at .+ line \d+, near .*//mg;
	    s/(uninitialized value)( within)? [\$@%].*? in /$1 in /g;
        }

        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(\%tmp) }
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{'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, '%h = ();', split(/\n/, $STD_TESTS);

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