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;
44 # If it's 5.7.3 or later the hash will be stored with flags, which is
45 # 2 extra bytes. There are 2 * 2 * 2 tests per byte in the body and header
46 # common to normal and network order serialised objects (hence the 8)
47 # There are only 2 * 2 tests per byte in the parts of the header not present
48 # for network order, and 2 tests per byte on the 'pst0' "magic number" only
49 # present in files, but not in things store()ed to memory
50 $fancy = ($] > 5.007 ? 2 : 0);
51 plan tests => 378 + length($Config{byteorder}) * 4 + $fancy * 8;
54 use Storable qw (store retrieve freeze thaw nstore nfreeze);
56 my $file = "malice.$$";
57 die "Temporary file 'malice.$$' already exists" if -e $file;
59 END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
61 # The chr 256 is a hack to force the hash to always have the utf8 keys flag
62 # set on 5.7.3 and later. Otherwise the test fails if run with -Mutf8 because
63 # only there does the hash has the flag on, and hence only there is it stored
64 # as a flagged hash, which is 2 bytes longer
65 my %hash = (perl => 'rules', chr 256, '');
66 delete $hash{chr 256};
70 ok (ref $clone, "HASH", "Get hash back");
71 ok (scalar keys %$clone, 1, "with 1 key");
72 ok ((keys %$clone)[0], "perl", "which is correct");
73 ok ($clone->{perl}, "rules");
77 my ($header, $isfile, $isnetorder) = @_;
78 ok (!!$header->{file}, !!$isfile, "is file");
79 ok ($header->{major}, $major, "major number");
80 ok ($header->{minor}, $minor_write, "minor number");
81 ok (!!$header->{netorder}, !!$isnetorder, "is network order");
85 ok (1, 1, "Network order header has no sizes");
88 ok ($header->{byteorder}, $Config{byteorder}, "byte order");
89 ok ($header->{intsize}, $Config{intsize}, "int size");
90 ok ($header->{longsize}, $Config{longsize}, "long size");
91 ok ($header->{ptrsize}, $Config{ptrsize}, "long size");
92 ok ($header->{nvsize}, $Config{nvsize} || $Config{doublesize} || 8,
93 "nv size"); # 5.00405 doesn't even have doublesize in config.
97 sub store_and_retrieve {
99 unlink $file or die "Can't unlink '$file': $!";
100 open FH, ">$file" or die "Can't open '$file': $!";
102 print FH $data or die "Can't print to '$file': $!";
103 close FH or die "Can't close '$file': $!";
105 return eval {retrieve $file};
108 sub freeze_and_thaw {
110 return eval {thaw $data};
114 my ($data, $sub, $magic_len, $what) = @_;
115 for my $i (0 .. length ($data) - 1) {
116 my $short = substr $data, 0, $i;
118 my $clone = &$sub($short);
119 ok (defined ($clone), '', "truncated $what to $i should fail");
120 if ($i < $magic_len) {
121 ok ($@, "/^Magic number checking on storable $what failed/",
122 "Should croak with magic number warning");
124 ok ($@, "", "Should not set \$\@");
130 my ($data, $sub, $what, $name) = @_;
132 my $clone = &$sub($data);
133 ok (defined ($clone), '', "$name $what should fail");
134 ok ($@, $what, $name);
138 my ($contents, $sub, $what, $isnetwork) = @_;
139 my $isfile = $what eq 'file';
140 my $file_magic = $isfile ? length $file_magic_str : 0;
142 my $header = Storable::read_magic ($contents);
143 test_header ($header, $isfile, $isnetwork);
145 # Test that if we re-write it, everything still works:
146 my $clone = &$sub ($contents);
148 ok ($@, "", "There should be no error");
152 # Now lets check the short version:
153 test_truncated ($contents, $sub, $file_magic
154 + ($isnetwork ? $network_magic : $other_magic), $what);
159 substr ($copy, 0, 4) = 'iron';
160 test_corrupt ($copy, $sub, "/^File is not a perl storable/",
165 # Needs to be more than 1, as we're already coding a spread of 1 minor version
166 # number on writes (2.5, 2.4). May increase to 2 if we figure we can do 2.3
167 # on 5.005_03 (No utf8).
168 # 4 allows for a small safety margin
170 # Question: What is the value of pi?
171 # Mathematician answers "It's pi, isn't it"
172 # Physicist answers "3.1, within experimental error"
173 # Engineer answers "Well, allowing for a small safety margin, 18"
175 my $minor4 = $header->{minor} + 4;
176 substr ($copy, $file_magic + 1, 1) = chr $minor4;
178 # Now by default newer minor version numbers are not a pain.
179 $clone = &$sub($copy);
180 ok ($@, "", "by default no error on higher minor");
183 local $Storable::accept_future_minor = 0;
184 test_corrupt ($copy, $sub,
185 "/^Storable binary image v$header->{major}\.$minor4 more recent than I am \\(v$header->{major}\.$minor\\)/",
190 my $major1 = $header->{major} + 1;
191 substr ($copy, $file_magic, 1) = chr 2*$major1;
192 test_corrupt ($copy, $sub,
193 "/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$minor\\)/",
196 # Continue messing with the previous copy
197 my $minor1 = $header->{minor} - 1;
198 substr ($copy, $file_magic + 1, 1) = chr $minor1;
199 test_corrupt ($copy, $sub,
200 "/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$minor\\)/",
201 "higher major, lower minor");
205 # All these are omitted from the network order header.
206 # I'm not sure if it's correct to omit the byte size stuff.
208 substr ($copy, $file_magic + 3, length $header->{byteorder})
209 = reverse $header->{byteorder};
211 test_corrupt ($copy, $sub, "/^Byte order is not compatible/",
213 $where = $file_magic + 3 + length $header->{byteorder};
214 foreach (['intsize', "Integer"],
215 ['longsize', "Long integer"],
216 ['ptrsize', "Pointer integer"],
217 ['nvsize', "Double"]) {
218 my ($key, $name) = @$_;
220 substr ($copy, $where++, 1) = chr 0;
221 test_corrupt ($copy, $sub, "/^$name size is not compatible/",
225 $where = $file_magic + $network_magic;
228 # Just the header and a tag 255. As 26 is currently the highest tag, this
230 $copy = substr ($contents, 0, $where) . chr 255;
232 test_corrupt ($copy, $sub,
233 "/^Corrupted storable $what \\(binary v$header->{major}.$header->{minor}\\)/",
236 # Now drop the minor version number
237 substr ($copy, $file_magic + 1, 1) = chr $minor1;
239 test_corrupt ($copy, $sub,
240 "/^Corrupted storable $what \\(binary v$header->{major}.$minor1\\)/",
241 "bogus tag, minor less 1");
242 # Now increase the minor version number
243 substr ($copy, $file_magic + 1, 1) = chr $minor4;
245 # local $Storable::DEBUGME = 1;
246 # This is the delayed croak
247 test_corrupt ($copy, $sub,
248 "/^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 25/",
249 "bogus tag, minor plus 4");
250 # And check again that this croak is not delayed:
252 # local $Storable::DEBUGME = 1;
253 local $Storable::accept_future_minor = 0;
254 test_corrupt ($copy, $sub,
255 "/^Storable binary image v$header->{major}\.$minor4 more recent than I am \\(v$header->{major}\.$minor\\)/",
263 open FH, "<$file" or die "Can't open '$file': $!";
266 die "Can't read $file: $!" unless defined $contents;
271 ok (defined store(\%hash, $file));
273 my $expected = 20 + length ($file_magic_str) + $other_magic + $fancy;
274 my $length = -s $file;
276 die "Don't seem to have written file '$file' as I can't get its length: $!"
277 unless defined $file;
279 die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
280 unless $length == $expected;
282 # Read the contents into memory:
283 my $contents = slurp $file;
285 # Test the original direct from disk
286 my $clone = retrieve $file;
290 test_things($contents, \&store_and_retrieve, 'file');
292 # And now try almost everything again with a Storable string
293 my $stored = freeze \%hash;
294 test_things($stored, \&freeze_and_thaw, 'string');
297 unlink $file or die "Can't unlink '$file': $!";
299 ok (defined nstore(\%hash, $file));
301 $expected = 20 + length ($file_magic_str) + $network_magic + $fancy;
304 die "Don't seem to have written file '$file' as I can't get its length: $!"
305 unless defined $file;
307 die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
308 unless $length == $expected;
310 # Read the contents into memory:
311 $contents = slurp $file;
313 # Test the original direct from disk
314 $clone = retrieve $file;
318 test_things($contents, \&store_and_retrieve, 'file', 1);
320 # And now try almost everything again with a Storable string
321 $stored = nfreeze \%hash;
322 test_things($stored, \&freeze_and_thaw, 'string', 1);