1N/A#!./perl -w
1N/A#
1N/A# Copyright 2002, Larry Wall.
1N/A#
1N/A# You may redistribute only under the same terms as Perl 5, as specified
1N/A# in the README file that comes with the distribution.
1N/A#
1N/A
1N/A# I'm trying to keep this test easily backwards compatible to 5.004, so no
1N/A# qr//;
1N/A
1N/A# This test tries to craft malicious data to test out as many different
1N/A# error traps in Storable as possible
1N/A# It also acts as a test for read_header
1N/A
1N/Asub BEGIN {
1N/A if ($ENV{PERL_CORE}){
1N/A chdir('t') if -d 't';
1N/A @INC = ('.', '../lib');
1N/A } else {
1N/A # This lets us distribute Test::More in t/
1N/A unshift @INC, 't';
1N/A }
1N/A require Config; import Config;
1N/A if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
1N/A print "1..0 # Skip: Storable was not built\n";
1N/A exit 0;
1N/A }
1N/A}
1N/A
1N/Ause strict;
1N/Ause vars qw($file_magic_str $other_magic $network_magic $byteorder
1N/A $major $minor $minor_write $fancy);
1N/A
1N/A$byteorder = $Config{byteorder};
1N/A
1N/A$file_magic_str = 'pst0';
1N/A$other_magic = 7 + length $byteorder;
1N/A$network_magic = 2;
1N/A$major = 2;
1N/A$minor = 6;
1N/A$minor_write = $] > 5.007 ? 6 : 4;
1N/A
1N/Ause Test::More;
1N/A
1N/A# If it's 5.7.3 or later the hash will be stored with flags, which is
1N/A# 2 extra bytes. There are 2 * 2 * 2 tests per byte in the body and header
1N/A# common to normal and network order serialised objects (hence the 8)
1N/A# There are only 2 * 2 tests per byte in the parts of the header not present
1N/A# for network order, and 2 tests per byte on the 'pst0' "magic number" only
1N/A# present in files, but not in things store()ed to memory
1N/A$fancy = ($] > 5.007 ? 2 : 0);
1N/A
1N/Aplan tests => 368 + length ($byteorder) * 4 + $fancy * 8 + 1;
1N/A
1N/Ause Storable qw (store retrieve freeze thaw nstore nfreeze);
1N/A
1N/Amy $file = "malice.$$";
1N/Adie "Temporary file 'malice.$$' already exists" if -e $file;
1N/A
1N/AEND { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
1N/A
1N/A# The chr 256 is a hack to force the hash to always have the utf8 keys flag
1N/A# set on 5.7.3 and later. Otherwise the test fails if run with -Mutf8 because
1N/A# only there does the hash has the flag on, and hence only there is it stored
1N/A# as a flagged hash, which is 2 bytes longer
1N/Amy %hash = (perl => 'rules', chr 256, '');
1N/Adelete $hash{chr 256};
1N/A
1N/Asub test_hash {
1N/A my $clone = shift;
1N/A is (ref $clone, "HASH", "Get hash back");
1N/A is (scalar keys %$clone, 1, "with 1 key");
1N/A is ((keys %$clone)[0], "perl", "which is correct");
1N/A is ($clone->{perl}, "rules");
1N/A}
1N/A
1N/Asub test_header {
1N/A my ($header, $isfile, $isnetorder) = @_;
1N/A is (!!$header->{file}, !!$isfile, "is file");
1N/A is ($header->{major}, $major, "major number");
1N/A is ($header->{minor}, $minor_write, "minor number");
1N/A is (!!$header->{netorder}, !!$isnetorder, "is network order");
1N/A if ($isnetorder) {
1N/A # Network order header has no sizes
1N/A } else {
1N/A is ($header->{byteorder}, $byteorder, "byte order");
1N/A is ($header->{intsize}, $Config{intsize}, "int size");
1N/A is ($header->{longsize}, $Config{longsize}, "long size");
1N/A SKIP: {
1N/A skip ("No \$Config{prtsize} on this perl version ($])", 1)
1N/A unless defined $Config{ptrsize};
1N/A is ($header->{ptrsize}, $Config{ptrsize}, "long size");
1N/A }
1N/A is ($header->{nvsize}, $Config{nvsize} || $Config{doublesize} || 8,
1N/A "nv size"); # 5.00405 doesn't even have doublesize in config.
1N/A }
1N/A}
1N/A
1N/Asub store_and_retrieve {
1N/A my $data = shift;
1N/A unlink $file or die "Can't unlink '$file': $!";
1N/A open FH, ">$file" or die "Can't open '$file': $!";
1N/A binmode FH;
1N/A print FH $data or die "Can't print to '$file': $!";
1N/A close FH or die "Can't close '$file': $!";
1N/A
1N/A return eval {retrieve $file};
1N/A}
1N/A
1N/Asub freeze_and_thaw {
1N/A my $data = shift;
1N/A return eval {thaw $data};
1N/A}
1N/A
1N/Asub test_truncated {
1N/A my ($data, $sub, $magic_len, $what) = @_;
1N/A for my $i (0 .. length ($data) - 1) {
1N/A my $short = substr $data, 0, $i;
1N/A
1N/A # local $Storable::DEBUGME = 1;
1N/A my $clone = &$sub($short);
1N/A is (defined ($clone), '', "truncated $what to $i should fail");
1N/A if ($i < $magic_len) {
1N/A like ($@, "/^Magic number checking on storable $what failed/",
1N/A "Should croak with magic number warning");
1N/A } else {
1N/A is ($@, "", "Should not set \$\@");
1N/A }
1N/A }
1N/A}
1N/A
1N/Asub test_corrupt {
1N/A my ($data, $sub, $what, $name) = @_;
1N/A
1N/A my $clone = &$sub($data);
1N/A is (defined ($clone), '', "$name $what should fail");
1N/A like ($@, $what, $name);
1N/A}
1N/A
1N/Asub test_things {
1N/A my ($contents, $sub, $what, $isnetwork) = @_;
1N/A my $isfile = $what eq 'file';
1N/A my $file_magic = $isfile ? length $file_magic_str : 0;
1N/A
1N/A my $header = Storable::read_magic ($contents);
1N/A test_header ($header, $isfile, $isnetwork);
1N/A
1N/A # Test that if we re-write it, everything still works:
1N/A my $clone = &$sub ($contents);
1N/A
1N/A is ($@, "", "There should be no error");
1N/A
1N/A test_hash ($clone);
1N/A
1N/A # Now lets check the short version:
1N/A test_truncated ($contents, $sub, $file_magic
1N/A + ($isnetwork ? $network_magic : $other_magic), $what);
1N/A
1N/A my $copy;
1N/A if ($isfile) {
1N/A $copy = $contents;
1N/A substr ($copy, 0, 4) = 'iron';
1N/A test_corrupt ($copy, $sub, "/^File is not a perl storable/",
1N/A "magic number");
1N/A }
1N/A
1N/A $copy = $contents;
1N/A # Needs to be more than 1, as we're already coding a spread of 1 minor version
1N/A # number on writes (2.5, 2.4). May increase to 2 if we figure we can do 2.3
1N/A # on 5.005_03 (No utf8).
1N/A # 4 allows for a small safety margin
1N/A # (Joke:
1N/A # Question: What is the value of pi?
1N/A # Mathematician answers "It's pi, isn't it"
1N/A # Physicist answers "3.1, within experimental error"
1N/A # Engineer answers "Well, allowing for a small safety margin, 18"
1N/A # )
1N/A my $minor4 = $header->{minor} + 4;
1N/A substr ($copy, $file_magic + 1, 1) = chr $minor4;
1N/A {
1N/A # Now by default newer minor version numbers are not a pain.
1N/A $clone = &$sub($copy);
1N/A is ($@, "", "by default no error on higher minor");
1N/A test_hash ($clone);
1N/A
1N/A local $Storable::accept_future_minor = 0;
1N/A test_corrupt ($copy, $sub,
1N/A "/^Storable binary image v$header->{major}\.$minor4 more recent than I am \\(v$header->{major}\.$minor\\)/",
1N/A "higher minor");
1N/A }
1N/A
1N/A $copy = $contents;
1N/A my $major1 = $header->{major} + 1;
1N/A substr ($copy, $file_magic, 1) = chr 2*$major1;
1N/A test_corrupt ($copy, $sub,
1N/A "/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$minor\\)/",
1N/A "higher major");
1N/A
1N/A # Continue messing with the previous copy
1N/A my $minor1 = $header->{minor} - 1;
1N/A substr ($copy, $file_magic + 1, 1) = chr $minor1;
1N/A test_corrupt ($copy, $sub,
1N/A "/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$minor\\)/",
1N/A "higher major, lower minor");
1N/A
1N/A my $where;
1N/A if (!$isnetwork) {
1N/A # All these are omitted from the network order header.
1N/A # I'm not sure if it's correct to omit the byte size stuff.
1N/A $copy = $contents;
1N/A substr ($copy, $file_magic + 3, length $header->{byteorder})
1N/A = reverse $header->{byteorder};
1N/A
1N/A test_corrupt ($copy, $sub, "/^Byte order is not compatible/",
1N/A "byte order");
1N/A $where = $file_magic + 3 + length $header->{byteorder};
1N/A foreach (['intsize', "Integer"],
1N/A ['longsize', "Long integer"],
1N/A ['ptrsize', "Pointer"],
1N/A ['nvsize', "Double"]) {
1N/A my ($key, $name) = @$_;
1N/A $copy = $contents;
1N/A substr ($copy, $where++, 1) = chr 0;
1N/A test_corrupt ($copy, $sub, "/^$name size is not compatible/",
1N/A "$name size");
1N/A }
1N/A } else {
1N/A $where = $file_magic + $network_magic;
1N/A }
1N/A
1N/A # Just the header and a tag 255. As 26 is currently the highest tag, this
1N/A # is "unexpected"
1N/A $copy = substr ($contents, 0, $where) . chr 255;
1N/A
1N/A test_corrupt ($copy, $sub,
1N/A "/^Corrupted storable $what \\(binary v$header->{major}.$header->{minor}\\)/",
1N/A "bogus tag");
1N/A
1N/A # Now drop the minor version number
1N/A substr ($copy, $file_magic + 1, 1) = chr $minor1;
1N/A
1N/A test_corrupt ($copy, $sub,
1N/A "/^Corrupted storable $what \\(binary v$header->{major}.$minor1\\)/",
1N/A "bogus tag, minor less 1");
1N/A # Now increase the minor version number
1N/A substr ($copy, $file_magic + 1, 1) = chr $minor4;
1N/A
1N/A # local $Storable::DEBUGME = 1;
1N/A # This is the delayed croak
1N/A test_corrupt ($copy, $sub,
1N/A "/^Storable binary image v$header->{major}.$minor4 contains data of type 255. This Storable is v$header->{major}.$minor and can only handle data types up to 26/",
1N/A "bogus tag, minor plus 4");
1N/A # And check again that this croak is not delayed:
1N/A {
1N/A # local $Storable::DEBUGME = 1;
1N/A local $Storable::accept_future_minor = 0;
1N/A test_corrupt ($copy, $sub,
1N/A "/^Storable binary image v$header->{major}\.$minor4 more recent than I am \\(v$header->{major}\.$minor\\)/",
1N/A "higher minor");
1N/A }
1N/A}
1N/A
1N/Asub slurp {
1N/A my $file = shift;
1N/A local (*FH, $/);
1N/A open FH, "<$file" or die "Can't open '$file': $!";
1N/A binmode FH;
1N/A my $contents = <FH>;
1N/A die "Can't read $file: $!" unless defined $contents;
1N/A return $contents;
1N/A}
1N/A
1N/A
1N/Aok (defined store(\%hash, $file));
1N/A
1N/Amy $expected = 20 + length ($file_magic_str) + $other_magic + $fancy;
1N/Amy $length = -s $file;
1N/A
1N/Adie "Don't seem to have written file '$file' as I can't get its length: $!"
1N/A unless defined $file;
1N/A
1N/Adie "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
1N/A unless $length == $expected;
1N/A
1N/A# Read the contents into memory:
1N/Amy $contents = slurp $file;
1N/A
1N/A# Test the original direct from disk
1N/Amy $clone = retrieve $file;
1N/Atest_hash ($clone);
1N/A
1N/A# Then test it.
1N/Atest_things($contents, \&store_and_retrieve, 'file');
1N/A
1N/A# And now try almost everything again with a Storable string
1N/Amy $stored = freeze \%hash;
1N/Atest_things($stored, \&freeze_and_thaw, 'string');
1N/A
1N/A# Network order.
1N/Aunlink $file or die "Can't unlink '$file': $!";
1N/A
1N/Aok (defined nstore(\%hash, $file));
1N/A
1N/A$expected = 20 + length ($file_magic_str) + $network_magic + $fancy;
1N/A$length = -s $file;
1N/A
1N/Adie "Don't seem to have written file '$file' as I can't get its length: $!"
1N/A unless defined $file;
1N/A
1N/Adie "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
1N/A unless $length == $expected;
1N/A
1N/A# Read the contents into memory:
1N/A$contents = slurp $file;
1N/A
1N/A# Test the original direct from disk
1N/A$clone = retrieve $file;
1N/Atest_hash ($clone);
1N/A
1N/A# Then test it.
1N/Atest_things($contents, \&store_and_retrieve, 'file', 1);
1N/A
1N/A# And now try almost everything again with a Storable string
1N/A$stored = nfreeze \%hash;
1N/Atest_things($stored, \&freeze_and_thaw, 'string', 1);
1N/A
1N/A# Test that the bug fixed by #20587 doesn't affect us under some older
1N/A# Perl. AMS 20030901
1N/A{
1N/A chop(my $a = chr(0xDF).chr(256));
1N/A my %a = (chr(0xDF) => 1);
1N/A $a{$a}++;
1N/A freeze \%a;
1N/A # If we were built with -DDEBUGGING, the assert() should have killed
1N/A # us, which will probably alert the user that something went wrong.
1N/A ok(1);
1N/A}