4 # Copyright 2002, Larry Wall.
6 # You may redistribute only under the same terms as Perl 5, as specified
7 # in the README file that comes with the distribution.
10 # I'm trying to keep this test easily backwards compatible to 5.004, so no
12 # Currently using Test not Test::More, as Test is in core that far back.
14 # This test tries to craft malicious data to test out as many different
15 # error traps in Storable as possible
16 # It also acts as a test for read_header
24 require Config; import Config;
25 if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
26 print "1..0 # Skip: Storable was not built\n";
29 # require 'lib/st-dump.pl';
33 use vars qw($file_magic_str $other_magic $network_magic);
34 $file_magic_str = 'pst0';
35 $other_magic = 7 + $Config{ivsize};
39 BEGIN { plan tests => 334 + $Config{ivsize} * 4}
41 use Storable qw (store retrieve freeze thaw nstore nfreeze);
43 my $file = "malice.$$";
44 die "Temporary file 'malice.$$' already exists" if -e $file;
46 END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
48 my %hash = (perl => 'rules');
52 ok (ref $clone, "HASH", "Get hash back");
53 ok (scalar keys %$clone, 1, "with 1 key");
54 ok ((keys %$clone)[0], "perl", "which is correct");
55 ok ($clone->{perl}, "rules");
59 my ($header, $isfile, $isnetorder) = @_;
60 ok (!!$header->{file}, !!$isfile, "is file");
61 ok ($header->{major}, 2, "major number");
62 ok ($header->{minor}, 5, "minor number");
63 ok (!!$header->{netorder}, !!$isnetorder, "is network order");
67 ok (1, 1, "Network order header has no sizes");
70 ok ($header->{byteorder}, $Config{byteorder}, "byte order");
71 ok ($header->{intsize}, $Config{intsize}, "int size");
72 ok ($header->{longsize}, $Config{longsize}, "long size");
73 ok ($header->{ptrsize}, $Config{ptrsize}, "ptr size");
74 ok ($header->{nvsize}, $Config{nvsize} || $Config{doublesize} || 8,
75 "nv size"); # 5.00405 doesn't even have doublesize in config.
79 sub store_and_retrieve {
81 unlink $file or die "Can't unlink '$file': $!";
82 open FH, ">$file" or die "Can't open '$file': $!";
84 print FH $data or die "Can't print to '$file': $!";
85 close FH or die "Can't close '$file': $!";
87 return eval {retrieve $file};
92 return eval {thaw $data};
96 my ($data, $sub, $magic_len, $what) = @_;
97 for my $i (0 .. length ($data) - 1) {
98 my $short = substr $data, 0, $i;
100 my $clone = &$sub($short);
101 ok (defined ($clone), '', "truncated $what to $i should fail");
102 if ($i < $magic_len) {
103 ok ($@, "/^Magic number checking on storable $what failed/",
104 "Should croak with magic number warning");
106 ok ($@, "", "Should not set \$\@");
112 my ($data, $sub, $what, $name) = @_;
114 my $clone = &$sub($data);
115 ok (defined ($clone), '', "$name $what should fail");
116 ok ($@, $what, $name);
120 my ($contents, $sub, $what, $isnetwork) = @_;
121 my $isfile = $what eq 'file';
122 my $file_magic = $isfile ? length $file_magic_str : 0;
124 my $header = Storable::read_magic ($contents);
125 test_header ($header, $isfile, $isnetwork);
127 # Test that if we re-write it, everything still works:
128 my $clone = &$sub ($contents);
130 ok ($@, "", "There should be no error");
134 # Now lets check the short version:
135 test_truncated ($contents, $sub, $file_magic
136 + ($isnetwork ? $network_magic : $other_magic), $what);
141 substr ($copy, 0, 4) = 'iron';
142 test_corrupt ($copy, $sub, "/^File is not a perl storable/",
147 my $minor1 = $header->{minor} + 1;
148 substr ($copy, $file_magic + 1, 1) = chr $minor1;
149 test_corrupt ($copy, $sub,
150 "/^Storable binary image v$header->{major}.$minor1 more recent than I am \\(v$header->{major}.$header->{minor}\\)/",
154 my $major1 = $header->{major} + 1;
155 substr ($copy, $file_magic, 1) = chr 2*$major1;
156 test_corrupt ($copy, $sub,
157 "/^Storable binary image v$major1.$header->{minor} more recent than I am \\(v$header->{major}.$header->{minor}\\)/",
160 # Continue messing with the previous copy
161 $minor1 = $header->{minor} - 1;
162 substr ($copy, $file_magic + 1, 1) = chr $minor1;
163 test_corrupt ($copy, $sub,
164 "/^Storable binary image v$major1.$minor1 more recent than I am \\(v$header->{major}.$header->{minor}\\)/",
165 "higher major, lower minor");
169 # All these are omitted from the network order header.
170 # I'm not sure if it's correct to omit the byte size stuff.
172 substr ($copy, $file_magic + 3, length $header->{byteorder})
173 = reverse $header->{byteorder};
175 test_corrupt ($copy, $sub, "/^Byte order is not compatible/",
177 $where = $file_magic + 3 + length $header->{byteorder};
178 foreach (['intsize', "Integer"],
179 ['ivsize', "Long integer"],
180 ['ptrsize', "Pointer integer"],
181 ['nvsize', "Double"]) {
182 my ($key, $name) = @$_;
184 substr ($copy, $where++, 1) = chr 0;
185 test_corrupt ($copy, $sub, "/^$name size is not compatible/",
189 $where = $file_magic + $network_magic;
192 # Just the header and a tag 255. As 26 is currently the highest tag, this
194 $copy = substr ($contents, 0, $where) . chr 255;
196 test_corrupt ($copy, $sub,
197 "/^Corrupted storable $what \\(binary v$header->{major}.$header->{minor}\\)/",
204 open FH, "<$file" or die "Can't open '$file': $!";
207 die "Can't read $file: $!" unless defined $contents;
212 ok (defined store(\%hash, $file));
214 my $expected = 20 + length ($file_magic_str) + $other_magic;
215 my $length = -s $file;
217 die "Don't seem to have written file '$file' as I can't get its length: $!"
218 unless defined $file;
220 die "Expected file to be $expected bytes (sizeof IV is $Config{ivsize}) but it is $length"
221 unless $length == $expected;
223 # Read the contents into memory:
224 my $contents = slurp $file;
226 # Test the original direct from disk
227 my $clone = retrieve $file;
231 test_things($contents, \&store_and_retrieve, 'file');
233 # And now try almost everything again with a Storable string
234 my $stored = freeze \%hash;
235 test_things($stored, \&freeze_and_thaw, 'string');
238 unlink $file or die "Can't unlink '$file': $!";
240 ok (defined nstore(\%hash, $file));
242 $expected = 20 + length ($file_magic_str) + $network_magic;
245 die "Don't seem to have written file '$file' as I can't get its length: $!"
246 unless defined $file;
248 die "Expected file to be $expected bytes (sizeof IV is $Config{ivsize}) but it is $length"
249 unless $length == $expected;
251 # Read the contents into memory:
252 $contents = slurp $file;
254 # Test the original direct from disk
255 $clone = retrieve $file;
259 test_things($contents, \&store_and_retrieve, 'file', 1);
261 # And now try almost everything again with a Storable string
262 $stored = nfreeze \%hash;
263 test_things($stored, \&freeze_and_thaw, 'string', 1);