diff options
Diffstat (limited to 'lib/Tie')
| -rwxr-xr-x | lib/Tie/Array/push.t | 25 | ||||
| -rw-r--r-- | lib/Tie/Array/splice.t | 17 | ||||
| -rwxr-xr-x | lib/Tie/Array/std.t | 13 | ||||
| -rwxr-xr-x | lib/Tie/Array/stdpush.t | 11 | ||||
| -rwxr-xr-x | lib/Tie/Handle/stdhandle.t | 47 | ||||
| -rw-r--r-- | lib/Tie/RefHash.t | 305 | ||||
| -rw-r--r-- | lib/Tie/SubstrHash.t | 111 |
7 files changed, 529 insertions, 0 deletions
diff --git a/lib/Tie/Array/push.t b/lib/Tie/Array/push.t new file mode 100755 index 0000000000..b19aa0d0e8 --- /dev/null +++ b/lib/Tie/Array/push.t @@ -0,0 +1,25 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '.'; + push @INC, '../lib'; +} + +{ + package Basic; + use Tie::Array; + @ISA = qw(Tie::Array); + + sub TIEARRAY { return bless [], shift } + sub FETCH { $_[0]->[$_[1]] } + sub STORE { $_[0]->[$_[1]] = $_[2] } + sub FETCHSIZE { scalar(@{$_[0]}) } + sub STORESIZE { $#{$_[0]} = $_[1]-1 } +} + +tie @x,Basic; +tie @get,Basic; +tie @got,Basic; +tie @tests,Basic; +require "op/push.t" diff --git a/lib/Tie/Array/splice.t b/lib/Tie/Array/splice.t new file mode 100644 index 0000000000..d7ea6cc1dc --- /dev/null +++ b/lib/Tie/Array/splice.t @@ -0,0 +1,17 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '.'; + push @INC, '../lib'; +} + +# bug id 20001020.002 +# -dlc 20001021 + +use Tie::Array; +tie @a,Tie::StdArray; +undef *Tie::StdArray::SPLICE; +require "op/splice.t" + +# Pre-fix, this failed tests 6-9 diff --git a/lib/Tie/Array/std.t b/lib/Tie/Array/std.t new file mode 100755 index 0000000000..c4ae07102e --- /dev/null +++ b/lib/Tie/Array/std.t @@ -0,0 +1,13 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '.'; + push @INC, '../lib'; +} + +use Tie::Array; +tie @foo,Tie::StdArray; +tie @ary,Tie::StdArray; +tie @bar,Tie::StdArray; +require "op/array.t" diff --git a/lib/Tie/Array/stdpush.t b/lib/Tie/Array/stdpush.t new file mode 100755 index 0000000000..31af30c32c --- /dev/null +++ b/lib/Tie/Array/stdpush.t @@ -0,0 +1,11 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '.'; + push @INC, '../lib'; +} + +use Tie::Array; +tie @x,Tie::StdArray; +require "op/push.t" diff --git a/lib/Tie/Handle/stdhandle.t b/lib/Tie/Handle/stdhandle.t new file mode 100755 index 0000000000..f03f5d92f6 --- /dev/null +++ b/lib/Tie/Handle/stdhandle.t @@ -0,0 +1,47 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Tie::Handle; +tie *tst,Tie::StdHandle; + +$f = 'tst'; + +print "1..13\n"; + +# my $file tests + +unlink("afile.new") if -f "afile"; +print "$!\nnot " unless open($f,"+>afile") && open($f, "+<", "afile"); +print "ok 1\n"; +print "$!\nnot " unless binmode($f); +print "ok 2\n"; +print "not " unless -f "afile"; +print "ok 3\n"; +print "not " unless print $f "SomeData\n"; +print "ok 4\n"; +print "not " unless tell($f) == 9; +print "ok 5\n"; +print "not " unless printf $f "Some %d value\n",1234; +print "ok 6\n"; +print "not " unless seek($f,0,0); +print "ok 7\n"; +$b = <$f>; +print "not " unless $b eq "SomeData\n"; +print "ok 8\n"; +print "not " if eof($f); +print "ok 9\n"; +read($f,($b=''),4); +print "'$b' not " unless $b eq 'Some'; +print "ok 10\n"; +print "not " unless getc($f) eq ' '; +print "ok 11\n"; +$b = <$f>; +print "not " unless eof($f); +print "ok 12\n"; +print "not " unless close($f); +print "ok 13\n"; +unlink("afile"); diff --git a/lib/Tie/RefHash.t b/lib/Tie/RefHash.t new file mode 100644 index 0000000000..d80b2e10fc --- /dev/null +++ b/lib/Tie/RefHash.t @@ -0,0 +1,305 @@ +#!/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); +$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); +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); + + +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; + } + + 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; +} + diff --git a/lib/Tie/SubstrHash.t b/lib/Tie/SubstrHash.t new file mode 100644 index 0000000000..8256db7b58 --- /dev/null +++ b/lib/Tie/SubstrHash.t @@ -0,0 +1,111 @@ +#!/usr/bin/perl -w +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '.'; + push @INC, '../lib'; +} + +print "1..20\n"; + +use strict; + +require Tie::SubstrHash; + +my %a; + +tie %a, 'Tie::SubstrHash', 3, 3, 3; + +$a{abc} = 123; +$a{bcd} = 234; + +print "not " unless $a{abc} == 123; +print "ok 1\n"; + +print "not " unless keys %a == 2; +print "ok 2\n"; + +delete $a{abc}; + +print "not " unless $a{bcd} == 234; +print "ok 3\n"; + +print "not " unless (values %a)[0] == 234; +print "ok 4\n"; + +eval { $a{abcd} = 123 }; +print "not " unless $@ =~ /Key "abcd" is not 3 characters long/; +print "ok 5\n"; + +eval { $a{abc} = 1234 }; +print "not " unless $@ =~ /Value "1234" is not 3 characters long/; +print "ok 6\n"; + +eval { $a = $a{abcd}; $a++ }; +print "not " unless $@ =~ /Key "abcd" is not 3 characters long/; +print "ok 7\n"; + +@a{qw(abc cde)} = qw(123 345); + +print "not " unless $a{cde} == 345; +print "ok 8\n"; + +eval { $a{def} = 456 }; +print "not " unless $@ =~ /Table is full \(3 elements\)/; +print "ok 9\n"; + +%a = (); + +print "not " unless keys %a == 0; +print "ok 10\n"; + +# Tests 11..16 by Linc Madison. + +my $hashsize = 119; # arbitrary values from my data +my %test; +tie %test, "Tie::SubstrHash", 13, 86, $hashsize; + +for (my $i = 1; $i <= $hashsize; $i++) { + my $key1 = $i + 100_000; # fix to uniform 6-digit numbers + my $key2 = "abcdefg$key1"; + $test{$key2} = ("abcdefgh" x 10) . "$key1"; +} + +for (my $i = 1; $i <= $hashsize; $i++) { + my $key1 = $i + 100_000; + my $key2 = "abcdefg$key1"; + unless ($test{$key2}) { + print "not "; + last; + } +} +print "ok 11\n"; + +print "not " unless Tie::SubstrHash::findgteprime(1) == 2; +print "ok 12\n"; + +print "not " unless Tie::SubstrHash::findgteprime(2) == 2; +print "ok 13\n"; + +print "not " unless Tie::SubstrHash::findgteprime(5.5) == 7; +print "ok 14\n"; + +print "not " unless Tie::SubstrHash::findgteprime(13) == 13; +print "ok 15\n"; + +print "not " unless Tie::SubstrHash::findgteprime(13.000001) == 17; +print "ok 16\n"; + +print "not " unless Tie::SubstrHash::findgteprime(114) == 127; +print "ok 17\n"; + +print "not " unless Tie::SubstrHash::findgteprime(1000) == 1009; +print "ok 18\n"; + +print "not " unless Tie::SubstrHash::findgteprime(1024) == 1031; +print "ok 19\n"; + +print "not " unless Tie::SubstrHash::findgteprime(10000) == 10007; +print "ok 20\n"; + |