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
35 $file_magic_str = 'pst0';
36 $other_magic = 7 + length($Config{byteorder});
40 $minor_write = $] > 5.007 ? 5 : 4;
43 BEGIN { plan tests => 334 + length($Config{byteorder}) * 4}
45 use Storable qw (store retrieve freeze thaw nstore nfreeze);
47 my $file = "malice.$$";
48 die "Temporary file 'malice.$$' already exists" if -e $file;
50 END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
52 my %hash = (perl => 'rules');
56 ok (ref $clone, "HASH", "Get hash back");
57 ok (scalar keys %$clone, 1, "with 1 key");
58 ok ((keys %$clone)[0], "perl", "which is correct");
59 ok ($clone->{perl}, "rules");
63 my ($header, $isfile, $isnetorder) = @_;
64 ok (!!$header->{file}, !!$isfile, "is file");
65 ok ($header->{major}, $major, "major number");
66 ok ($header->{minor}, $minor_write, "minor number");
67 ok (!!$header->{netorder}, !!$isnetorder, "is network order");
71 ok (1, 1, "Network order header has no sizes");
74 ok ($header->{byteorder}, $Config{byteorder}, "byte order");
75 ok ($header->{intsize}, $Config{intsize}, "int size");
76 ok ($header->{longsize}, $Config{longsize}, "long size");
77 ok ($header->{ptrsize}, $Config{ptrsize}, "long size");
78 ok ($header->{nvsize}, $Config{nvsize} || $Config{doublesize} || 8,
79 "nv size"); # 5.00405 doesn't even have doublesize in config.
83 sub store_and_retrieve {
85 unlink $file or die "Can't unlink '$file': $!";
86 open FH, ">$file" or die "Can't open '$file': $!";
88 print FH $data or die "Can't print to '$file': $!";
89 close FH or die "Can't close '$file': $!";
91 return eval {retrieve $file};
96 return eval {thaw $data};
100 my ($data, $sub, $magic_len, $what) = @_;
101 for my $i (0 .. length ($data) - 1) {
102 my $short = substr $data, 0, $i;
104 my $clone = &$sub($short);
105 ok (defined ($clone), '', "truncated $what to $i should fail");
106 if ($i < $magic_len) {
107 ok ($@, "/^Magic number checking on storable $what failed/",
108 "Should croak with magic number warning");
110 ok ($@, "", "Should not set \$\@");
116 my ($data, $sub, $what, $name) = @_;
118 my $clone = &$sub($data);
119 ok (defined ($clone), '', "$name $what should fail");
120 ok ($@, $what, $name);
124 my ($contents, $sub, $what, $isnetwork) = @_;
125 my $isfile = $what eq 'file';
126 my $file_magic = $isfile ? length $file_magic_str : 0;
128 my $header = Storable::read_magic ($contents);
129 test_header ($header, $isfile, $isnetwork);
131 # Test that if we re-write it, everything still works:
132 my $clone = &$sub ($contents);
134 ok ($@, "", "There should be no error");
138 # Now lets check the short version:
139 test_truncated ($contents, $sub, $file_magic
140 + ($isnetwork ? $network_magic : $other_magic), $what);
145 substr ($copy, 0, 4) = 'iron';
146 test_corrupt ($copy, $sub, "/^File is not a perl storable/",
151 # Needs to be more than 1, as we're already coding a spread of 1 minor version
152 # number on writes (2.5, 2.4). May increase to 2 if we figure we can do 2.3
153 # on 5.005_03 (No utf8).
154 # 4 allows for a small safety margin
156 # Question: What is the value of pi?
157 # Mathematician answers "It's pi, isn't it"
158 # Physicist answers "3.1, within experimental error"
159 # Engineer answers "Well, allowing for a small safety margin, 18"
161 my $minor4 = $header->{minor} + 4;
162 substr ($copy, $file_magic + 1, 1) = chr $minor4;
163 test_corrupt ($copy, $sub,
164 "/^Storable binary image v$header->{major}\.$minor4 more recent than I am \\(v$header->{major}\.$minor\\)/",
168 my $major1 = $header->{major} + 1;
169 substr ($copy, $file_magic, 1) = chr 2*$major1;
170 test_corrupt ($copy, $sub,
171 "/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$minor\\)/",
174 # Continue messing with the previous copy
175 my $minor1 = $header->{minor} - 1;
176 substr ($copy, $file_magic + 1, 1) = chr $minor1;
177 test_corrupt ($copy, $sub,
178 "/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$minor\\)/",
179 "higher major, lower minor");
183 # All these are omitted from the network order header.
184 # I'm not sure if it's correct to omit the byte size stuff.
186 substr ($copy, $file_magic + 3, length $header->{byteorder})
187 = reverse $header->{byteorder};
189 test_corrupt ($copy, $sub, "/^Byte order is not compatible/",
191 $where = $file_magic + 3 + length $header->{byteorder};
192 foreach (['intsize', "Integer"],
193 ['longsize', "Long integer"],
194 ['ptrsize', "Pointer integer"],
195 ['nvsize', "Double"]) {
196 my ($key, $name) = @$_;
198 substr ($copy, $where++, 1) = chr 0;
199 test_corrupt ($copy, $sub, "/^$name size is not compatible/",
203 $where = $file_magic + $network_magic;
206 # Just the header and a tag 255. As 26 is currently the highest tag, this
208 $copy = substr ($contents, 0, $where) . chr 255;
210 test_corrupt ($copy, $sub,
211 "/^Corrupted storable $what \\(binary v$header->{major}.$header->{minor}\\)/",
218 open FH, "<$file" or die "Can't open '$file': $!";
221 die "Can't read $file: $!" unless defined $contents;
226 ok (defined store(\%hash, $file));
228 my $expected = 20 + length ($file_magic_str) + $other_magic;
229 my $length = -s $file;
231 die "Don't seem to have written file '$file' as I can't get its length: $!"
232 unless defined $file;
234 die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
235 unless $length == $expected;
237 # Read the contents into memory:
238 my $contents = slurp $file;
240 # Test the original direct from disk
241 my $clone = retrieve $file;
245 test_things($contents, \&store_and_retrieve, 'file');
247 # And now try almost everything again with a Storable string
248 my $stored = freeze \%hash;
249 test_things($stored, \&freeze_and_thaw, 'string');
252 unlink $file or die "Can't unlink '$file': $!";
254 ok (defined nstore(\%hash, $file));
256 $expected = 20 + length ($file_magic_str) + $network_magic;
259 die "Don't seem to have written file '$file' as I can't get its length: $!"
260 unless defined $file;
262 die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
263 unless $length == $expected;
265 # Read the contents into memory:
266 $contents = slurp $file;
268 # Test the original direct from disk
269 $clone = retrieve $file;
273 test_things($contents, \&store_and_retrieve, 'file', 1);
275 # And now try almost everything again with a Storable string
276 $stored = nfreeze \%hash;
277 test_things($stored, \&freeze_and_thaw, 'string', 1);