From: Nicholas Clark Date: Sun, 21 Apr 2002 19:15:24 +0000 (+0100) Subject: another Storable test (Re: perl@16005) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b8778c7c6345cf412905d167e9498cfd0d4983ea;p=p5sagit%2Fp5-mst-13.2.git another Storable test (Re: perl@16005) Message-ID: <20020421181523.GC332@Bagpuss.unfortu.net> p4raw-id: //depot/perl@16047 --- diff --git a/MANIFEST b/MANIFEST index 09fab2b..a53d0b3 100644 --- a/MANIFEST +++ b/MANIFEST @@ -597,6 +597,7 @@ ext/Storable/t/dclone.t See if Storable works ext/Storable/t/forgive.t See if Storable works ext/Storable/t/freeze.t See if Storable works ext/Storable/t/lock.t See if Storable works +ext/Storable/t/malice.t See if Storable copes with corrupt files ext/Storable/t/overload.t See if Storable works ext/Storable/t/recurse.t See if Storable works ext/Storable/t/restrict.t See if Storable works diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm index 869f5b6..2f352f3 100644 --- a/ext/Storable/Storable.pm +++ b/ext/Storable/Storable.pm @@ -110,15 +110,19 @@ BEGIN { sub logcroak; sub logcarp; +# Can't Autoload cleanly as this clashes 8.3 with &retrieve sub retrieve_fd { &fd_retrieve } # Backward compatibility +bootstrap Storable; +1; +__END__ + # # Determine whether locking is possible, but only when needed. # -my $CAN_FLOCK; - sub CAN_FLOCK { + my $CAN_FLOCK if 0; return $CAN_FLOCK if defined $CAN_FLOCK; require Config; import Config; return $CAN_FLOCK = @@ -149,9 +153,40 @@ sub show_file_magic { EOM } -bootstrap Storable; -1; -__END__ +sub read_magic { + my $header = shift; + return unless defined $header and length $header > 11; + my $result; + if ($header =~ s/^perl-store//) { + die "Can't deal with version 0 headers"; + } elsif ($header =~ s/^pst0//) { + $result->{file} = 1; + } + # Assume it's a string. + my ($major, $minor, $bytelen) = unpack "C3", $header; + + my $net_order = $major & 1; + $major >>= 1; + @$result{qw(major minor netorder)} = ($major, $minor, $net_order); + + return $result if $net_order; + + # I assume that it is rare to find v1 files, so this is an intentionally + # inefficient way of doing it, to make the rest of the code constant. + if ($major < 2) { + delete $result->{minor}; + $header = '.' . $header; + $bytelen = $minor; + } + + @$result{qw(byteorder intsize longsize ptrsize)} = + unpack "x3 A$bytelen C3", $header; + + if ($major >= 2 and $minor >= 2) { + $result->{nvsize} = unpack "x6 x$bytelen C", $header; + } + $result; +} # # store diff --git a/ext/Storable/t/malice.t b/ext/Storable/t/malice.t new file mode 100644 index 0000000..5bd81ec --- /dev/null +++ b/ext/Storable/t/malice.t @@ -0,0 +1,263 @@ +#!./perl -w + +# +# Copyright 2002, Larry Wall. +# +# You may redistribute only under the same terms as Perl 5, as specified +# in the README file that comes with the distribution. +# + +# I'm trying to keep this test easily backwards compatible to 5.004, so no +# qr//; +# Currently using Test not Test::More, as Test is in core that far back. + +# This test tries to craft malicious data to test out as many different +# error traps in Storable as possible +# It also acts as a test for read_header + +sub BEGIN { + if ($ENV{PERL_CORE}){ + chdir('t') if -d 't'; + @INC = '.'; + push @INC, '../lib'; + } + require Config; import Config; + if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { + print "1..0 # Skip: Storable was not built\n"; + exit 0; + } + # require 'lib/st-dump.pl'; +} + +use strict; +use vars qw($file_magic_str $other_magic $network_magic); +$file_magic_str = 'pst0'; +$other_magic = 7 + $Config{longsize}; +$network_magic = 2; + +use Test; +BEGIN { plan tests => 334 + $Config{longsize} * 4} + +use Storable qw (store retrieve freeze thaw nstore nfreeze); + +my $file = "malice.$$"; +die "Temporary file 'malice.$$' already exists" if -e $file; + +END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }} + +my %hash = (perl => 'rules'); + +sub test_hash { + my $clone = shift; + ok (ref $clone, "HASH", "Get hash back"); + ok (scalar keys %$clone, 1, "with 1 key"); + ok ((keys %$clone)[0], "perl", "which is correct"); + ok ($clone->{perl}, "rules"); +} + +sub test_header { + my ($header, $isfile, $isnetorder) = @_; + ok (!!$header->{file}, !!$isfile, "is file"); + ok ($header->{major}, 2, "major number"); + ok ($header->{minor}, 5, "minor number"); + ok (!!$header->{netorder}, !!$isnetorder, "is network order"); + if ($isnetorder) { + # Skip these + for (1..5) { + ok (1, 1, "Network order header has no sizes"); + } + } else { + ok ($header->{byteorder}, $Config{byteorder}, "byte order"); + ok ($header->{intsize}, $Config{intsize}, "int size"); + ok ($header->{longsize}, $Config{longsize}, "long size"); + ok ($header->{ptrsize}, $Config{ptrsize}, "long size"); + ok ($header->{nvsize}, $Config{nvsize} || $Config{doublesize} || 8, + "nv size"); # 5.00405 doesn't even have doublesize in config. + } +} + +sub store_and_retrieve { + my $data = shift; + unlink $file or die "Can't unlink '$file': $!"; + open FH, ">$file" or die "Can't open '$file': $!"; + binmode FH; + print FH $data or die "Can't print to '$file': $!"; + close FH or die "Can't close '$file': $!"; + + return eval {retrieve $file}; +} + +sub freeze_and_thaw { + my $data = shift; + return eval {thaw $data}; +} + +sub test_truncated { + my ($data, $sub, $magic_len, $what) = @_; + for my $i (0 .. length ($data) - 1) { + my $short = substr $data, 0, $i; + + my $clone = &$sub($short); + ok (defined ($clone), '', "truncated $what to $i should fail"); + if ($i < $magic_len) { + ok ($@, "/^Magic number checking on storable $what failed/", + "Should croak with magic number warning"); + } else { + ok ($@, "", "Should not set \$\@"); + } + } +} + +sub test_corrupt { + my ($data, $sub, $what, $name) = @_; + + my $clone = &$sub($data); + ok (defined ($clone), '', "$name $what should fail"); + ok ($@, $what, $name); +} + +sub test_things { + my ($contents, $sub, $what, $isnetwork) = @_; + my $isfile = $what eq 'file'; + my $file_magic = $isfile ? length $file_magic_str : 0; + + my $header = Storable::read_magic ($contents); + test_header ($header, $isfile, $isnetwork); + + # Test that if we re-write it, everything still works: + my $clone = &$sub ($contents); + + ok ($@, "", "There should be no error"); + + test_hash ($clone); + + # Now lets check the short version: + test_truncated ($contents, $sub, $file_magic + + ($isnetwork ? $network_magic : $other_magic), $what); + + my $copy; + if ($isfile) { + $copy = $contents; + substr ($copy, 0, 4) = 'iron'; + test_corrupt ($copy, $sub, "/^File is not a perl storable/", + "magic number"); + } + + $copy = $contents; + my $minor1 = $header->{minor} + 1; + substr ($copy, $file_magic + 1, 1) = chr $minor1; + test_corrupt ($copy, $sub, + "/^Storable binary image v$header->{major}.$minor1 more recent than I am \\(v$header->{major}.$header->{minor}\\)/", + "higher minor"); + + $copy = $contents; + my $major1 = $header->{major} + 1; + substr ($copy, $file_magic, 1) = chr 2*$major1; + test_corrupt ($copy, $sub, + "/^Storable binary image v$major1.$header->{minor} more recent than I am \\(v$header->{major}.$header->{minor}\\)/", + "higher major"); + + # Continue messing with the previous copy + $minor1 = $header->{minor} - 1; + substr ($copy, $file_magic + 1, 1) = chr $minor1; + test_corrupt ($copy, $sub, + "/^Storable binary image v$major1.$minor1 more recent than I am \\(v$header->{major}.$header->{minor}\\)/", + "higher major, lower minor"); + + my $where; + if (!$isnetwork) { + # All these are omitted from the network order header. + # I'm not sure if it's correct to omit the byte size stuff. + $copy = $contents; + substr ($copy, $file_magic + 3, length $header->{byteorder}) + = reverse $header->{byteorder}; + + test_corrupt ($copy, $sub, "/^Byte order is not compatible/", + "byte order"); + $where = $file_magic + 3 + length $header->{byteorder}; + foreach (['intsize', "Integer"], + ['longsize', "Long integer"], + ['ptrsize', "Pointer integer"], + ['nvsize', "Double"]) { + my ($key, $name) = @$_; + $copy = $contents; + substr ($copy, $where++, 1) = chr 0; + test_corrupt ($copy, $sub, "/^$name size is not compatible/", + "$name size"); + } + } else { + $where = $file_magic + $network_magic; + } + + # Just the header and a tag 255. As 26 is currently the highest tag, this + # is "unexpected" + $copy = substr ($contents, 0, $where) . chr 255; + + test_corrupt ($copy, $sub, + "/^Corrupted storable $what \\(binary v$header->{major}.$header->{minor}\\)/", + "bogus tag"); +} + +sub slurp { + my $file = shift; + local (*FH, $/); + open FH, "<$file" or die "Can't open '$file': $!"; + binmode FH; + my $contents = ; + die "Can't read $file: $!" unless defined $contents; + return $contents; +} + + +ok (defined store(\%hash, $file)); + +my $expected = 20 + length ($file_magic_str) + $other_magic; +my $length = -s $file; + +die "Don't seem to have written file '$file' as I can't get its length: $!" + unless defined $file; + +die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length" + unless $length == $expected; + +# Read the contents into memory: +my $contents = slurp $file; + +# Test the original direct from disk +my $clone = retrieve $file; +test_hash ($clone); + +# Then test it. +test_things($contents, \&store_and_retrieve, 'file'); + +# And now try almost everything again with a Storable string +my $stored = freeze \%hash; +test_things($stored, \&freeze_and_thaw, 'string'); + +# Network order. +unlink $file or die "Can't unlink '$file': $!"; + +ok (defined nstore(\%hash, $file)); + +$expected = 20 + length ($file_magic_str) + $network_magic; +$length = -s $file; + +die "Don't seem to have written file '$file' as I can't get its length: $!" + unless defined $file; + +die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length" + unless $length == $expected; + +# Read the contents into memory: +$contents = slurp $file; + +# Test the original direct from disk +$clone = retrieve $file; +test_hash ($clone); + +# Then test it. +test_things($contents, \&store_and_retrieve, 'file', 1); + +# And now try almost everything again with a Storable string +$stored = nfreeze \%hash; +test_things($stored, \&freeze_and_thaw, 'string', 1);