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 $major $minor
34 $C_visible_byteorder);
37 # Config.pm does games to figure out byteorder dynamically. In the process
38 # it creates an 8 digit entry on long long builds on 32 bit long systems.
39 # config.sh, config.h and therefore Storable.xs have a 4 digit entry.
40 $C_visible_byteorder = $Config{byteorder};
41 if ($^O ne 'MSWin32' and $Config{longsize} != $Config{ivsize}) {
42 if ($C_visible_byteorder =~ /^1234/) {
44 substr ($C_visible_byteorder, $Config{longsize}) = '';
45 } elsif ($C_visible_byteorder =~ /4321$/) {
47 $C_visible_byteorder = substr ($C_visible_byteorder, -$Config{longsize});
49 die "longs are $Config{longsize} bytes, IVs are $Config{ivsize}, byte order $C_visible_byteorder not regonised";
54 # header size depends on the size of the byteorder string
55 $file_magic_str = 'pst0';
56 $other_magic = 7 + length($C_visible_byteorder);
62 BEGIN { plan tests => 334 + length($C_visible_byteorder) * 4}
64 use Storable qw (store retrieve freeze thaw nstore nfreeze);
66 my $file = "malice.$$";
67 die "Temporary file 'malice.$$' already exists" if -e $file;
69 END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
71 my %hash = (perl => 'rules');
75 ok (ref $clone, "HASH", "Get hash back");
76 ok (scalar keys %$clone, 1, "with 1 key");
77 ok ((keys %$clone)[0], "perl", "which is correct");
78 ok ($clone->{perl}, "rules");
82 my ($header, $isfile, $isnetorder) = @_;
83 ok (!!$header->{file}, !!$isfile, "is file");
84 ok ($header->{major}, $major, "major number");
85 ok ($header->{minor}, $minor, "minor number");
86 ok (!!$header->{netorder}, !!$isnetorder, "is network order");
90 ok (1, 1, "Network order header has no sizes");
93 ok ($header->{byteorder}, $C_visible_byteorder, "byte order");
94 ok ($header->{intsize}, $Config{intsize}, "int size");
95 ok ($header->{longsize}, $Config{longsize}, "long size");
96 ok ($header->{ptrsize}, $Config{ptrsize}, "long size");
97 ok ($header->{nvsize}, $Config{nvsize} || $Config{doublesize} || 8,
98 "nv size"); # 5.00405 doesn't even have doublesize in config.
102 sub store_and_retrieve {
104 unlink $file or die "Can't unlink '$file': $!";
105 open FH, ">$file" or die "Can't open '$file': $!";
107 print FH $data or die "Can't print to '$file': $!";
108 close FH or die "Can't close '$file': $!";
110 return eval {retrieve $file};
113 sub freeze_and_thaw {
115 return eval {thaw $data};
119 my ($data, $sub, $magic_len, $what) = @_;
120 for my $i (0 .. length ($data) - 1) {
121 my $short = substr $data, 0, $i;
123 my $clone = &$sub($short);
124 ok (defined ($clone), '', "truncated $what to $i should fail");
125 if ($i < $magic_len) {
126 ok ($@, "/^Magic number checking on storable $what failed/",
127 "Should croak with magic number warning");
129 ok ($@, "", "Should not set \$\@");
135 my ($data, $sub, $what, $name) = @_;
137 my $clone = &$sub($data);
138 ok (defined ($clone), '', "$name $what should fail");
139 ok ($@, $what, $name);
143 my ($contents, $sub, $what, $isnetwork) = @_;
144 my $isfile = $what eq 'file';
145 my $file_magic = $isfile ? length $file_magic_str : 0;
147 my $header = Storable::read_magic ($contents);
148 test_header ($header, $isfile, $isnetwork);
150 # Test that if we re-write it, everything still works:
151 my $clone = &$sub ($contents);
153 ok ($@, "", "There should be no error");
157 # Now lets check the short version:
158 test_truncated ($contents, $sub, $file_magic
159 + ($isnetwork ? $network_magic : $other_magic), $what);
164 substr ($copy, 0, 4) = 'iron';
165 test_corrupt ($copy, $sub, "/^File is not a perl storable/",
170 my $minor1 = $header->{minor} + 1;
171 substr ($copy, $file_magic + 1, 1) = chr $minor1;
172 test_corrupt ($copy, $sub,
173 "/^Storable binary image v$header->{major}\.$minor1 more recent than I am \\(v$header->{major}\.$header->{minor}\\)/",
177 my $major1 = $header->{major} + 1;
178 substr ($copy, $file_magic, 1) = chr 2*$major1;
179 test_corrupt ($copy, $sub,
180 "/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$header->{minor}\\)/",
183 # Continue messing with the previous copy
184 $minor1 = $header->{minor} - 1;
185 substr ($copy, $file_magic + 1, 1) = chr $minor1;
186 test_corrupt ($copy, $sub,
187 "/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$header->{minor}\\)/",
188 "higher major, lower minor");
192 # All these are omitted from the network order header.
193 # I'm not sure if it's correct to omit the byte size stuff.
195 substr ($copy, $file_magic + 3, length $header->{byteorder})
196 = reverse $header->{byteorder};
198 test_corrupt ($copy, $sub, "/^Byte order is not compatible/",
200 $where = $file_magic + 3 + length $header->{byteorder};
201 foreach (['intsize', "Integer"],
202 ['longsize', "Long integer"],
203 ['ptrsize', "Pointer integer"],
204 ['nvsize', "Double"]) {
205 my ($key, $name) = @$_;
207 substr ($copy, $where++, 1) = chr 0;
208 test_corrupt ($copy, $sub, "/^$name size is not compatible/",
212 $where = $file_magic + $network_magic;
215 # Just the header and a tag 255. As 26 is currently the highest tag, this
217 $copy = substr ($contents, 0, $where) . chr 255;
219 test_corrupt ($copy, $sub,
220 "/^Corrupted storable $what \\(binary v$header->{major}.$header->{minor}\\)/",
227 open FH, "<$file" or die "Can't open '$file': $!";
230 die "Can't read $file: $!" unless defined $contents;
235 ok (defined store(\%hash, $file));
237 my $expected = 20 + length ($file_magic_str) + $other_magic;
238 my $length = -s $file;
240 die "Don't seem to have written file '$file' as I can't get its length: $!"
241 unless defined $file;
243 die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
244 unless $length == $expected;
246 # Read the contents into memory:
247 my $contents = slurp $file;
249 # Test the original direct from disk
250 my $clone = retrieve $file;
254 test_things($contents, \&store_and_retrieve, 'file');
256 # And now try almost everything again with a Storable string
257 my $stored = freeze \%hash;
258 test_things($stored, \&freeze_and_thaw, 'string');
261 unlink $file or die "Can't unlink '$file': $!";
263 ok (defined nstore(\%hash, $file));
265 $expected = 20 + length ($file_magic_str) + $network_magic;
268 die "Don't seem to have written file '$file' as I can't get its length: $!"
269 unless defined $file;
271 die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
272 unless $length == $expected;
274 # Read the contents into memory:
275 $contents = slurp $file;
277 # Test the original direct from disk
278 $clone = retrieve $file;
282 test_things($contents, \&store_and_retrieve, 'file', 1);
284 # And now try almost everything again with a Storable string
285 $stored = nfreeze \%hash;
286 test_things($stored, \&freeze_and_thaw, 'string', 1);