3 # Copyright 2002, Larry Wall.
5 # You may redistribute only under the same terms as Perl 5, as specified
6 # in the README file that comes with the distribution.
9 # I'm trying to keep this test easily backwards compatible to 5.004, so no
12 # This test tries to craft malicious data to test out as many different
13 # error traps in Storable as possible
14 # It also acts as a test for read_header
17 # This lets us distribute Test::More in t/
19 require Config; import Config;
20 if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
21 print "1..0 # Skip: Storable was not built\n";
27 use vars qw($file_magic_str $other_magic $network_magic $byteorder
28 $major $minor $minor_write $fancy);
30 $byteorder = $Config{byteorder};
32 $file_magic_str = 'pst0';
33 $other_magic = 7 + length $byteorder;
37 $minor_write = $] > 5.005_50 ? 7 : 4;
41 # If it's 5.7.3 or later the hash will be stored with flags, which is
42 # 2 extra bytes. There are 2 * 2 * 2 tests per byte in the body and header
43 # common to normal and network order serialised objects (hence the 8)
44 # There are only 2 * 2 tests per byte in the parts of the header not present
45 # for network order, and 2 tests per byte on the 'pst0' "magic number" only
46 # present in files, but not in things store()ed to memory
47 $fancy = ($] > 5.007 ? 2 : 0);
49 plan tests => 372 + length ($byteorder) * 4 + $fancy * 8;
51 use Storable qw (store retrieve freeze thaw nstore nfreeze);
55 # The chr 256 is a hack to force the hash to always have the utf8 keys flag
56 # set on 5.7.3 and later. Otherwise the test fails if run with -Mutf8 because
57 # only there does the hash has the flag on, and hence only there is it stored
58 # as a flagged hash, which is 2 bytes longer
59 my %hash = (perl => 'rules', chr 256, '');
60 delete $hash{chr 256};
64 is (ref $clone, "HASH", "Get hash back");
65 is (scalar keys %$clone, 1, "with 1 key");
66 is ((keys %$clone)[0], "perl", "which is correct");
67 is ($clone->{perl}, "rules");
71 my ($header, $isfile, $isnetorder) = @_;
72 is (!!$header->{file}, !!$isfile, "is file");
73 is ($header->{major}, $major, "major number");
74 is ($header->{minor}, $minor_write, "minor number");
75 is (!!$header->{netorder}, !!$isnetorder, "is network order");
77 # Network order header has no sizes
79 is ($header->{byteorder}, $byteorder, "byte order");
80 is ($header->{intsize}, $Config{intsize}, "int size");
81 is ($header->{longsize}, $Config{longsize}, "long size");
83 skip ("No \$Config{prtsize} on this perl version ($])", 1)
84 unless defined $Config{ptrsize};
85 is ($header->{ptrsize}, $Config{ptrsize}, "long size");
87 is ($header->{nvsize}, $Config{nvsize} || $Config{doublesize} || 8,
88 "nv size"); # 5.00405 doesn't even have doublesize in config.
93 my ($data, $sub, $magic_len, $what) = @_;
94 for my $i (0 .. length ($data) - 1) {
95 my $short = substr $data, 0, $i;
97 # local $Storable::DEBUGME = 1;
98 my $clone = &$sub($short);
99 is (defined ($clone), '', "truncated $what to $i should fail");
100 if ($i < $magic_len) {
101 like ($@, "/^Magic number checking on storable $what failed/",
102 "Should croak with magic number warning");
104 is ($@, "", "Should not set \$\@");
110 my ($data, $sub, $what, $name) = @_;
112 my $clone = &$sub($data);
113 is (defined ($clone), '', "$name $what should fail");
114 like ($@, $what, $name);
118 my ($contents, $sub, $what, $isnetwork) = @_;
119 my $isfile = $what eq 'file';
120 my $file_magic = $isfile ? length $file_magic_str : 0;
122 my $header = Storable::read_magic ($contents);
123 test_header ($header, $isfile, $isnetwork);
125 # Test that if we re-write it, everything still works:
126 my $clone = &$sub ($contents);
128 is ($@, "", "There should be no error");
132 # Now lets check the short version:
133 test_truncated ($contents, $sub, $file_magic
134 + ($isnetwork ? $network_magic : $other_magic), $what);
139 substr ($copy, 0, 4) = 'iron';
140 test_corrupt ($copy, $sub, "/^File is not a perl storable/",
145 # Needs to be more than 1, as we're already coding a spread of 1 minor version
146 # number on writes (2.5, 2.4). May increase to 2 if we figure we can do 2.3
147 # on 5.005_03 (No utf8).
148 # 4 allows for a small safety margin
150 # Question: What is the value of pi?
151 # Mathematician answers "It's pi, isn't it"
152 # Physicist answers "3.1, within experimental error"
153 # Engineer answers "Well, allowing for a small safety margin, 18"
155 my $minor4 = $header->{minor} + 4;
156 substr ($copy, $file_magic + 1, 1) = chr $minor4;
158 # Now by default newer minor version numbers are not a pain.
159 $clone = &$sub($copy);
160 is ($@, "", "by default no error on higher minor");
163 local $Storable::accept_future_minor = 0;
164 test_corrupt ($copy, $sub,
165 "/^Storable binary image v$header->{major}\.$minor4 more recent than I am \\(v$header->{major}\.$minor\\)/",
170 my $major1 = $header->{major} + 1;
171 substr ($copy, $file_magic, 1) = chr 2*$major1;
172 test_corrupt ($copy, $sub,
173 "/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$minor\\)/",
176 # Continue messing with the previous copy
177 my $minor1 = $header->{minor} - 1;
178 substr ($copy, $file_magic + 1, 1) = chr $minor1;
179 test_corrupt ($copy, $sub,
180 "/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$minor\\)/",
181 "higher major, lower minor");
185 # All these are omitted from the network order header.
186 # I'm not sure if it's correct to omit the byte size stuff.
188 substr ($copy, $file_magic + 3, length $header->{byteorder})
189 = reverse $header->{byteorder};
191 test_corrupt ($copy, $sub, "/^Byte order is not compatible/",
193 $where = $file_magic + 3 + length $header->{byteorder};
194 foreach (['intsize', "Integer"],
195 ['longsize', "Long integer"],
196 ['ptrsize', "Pointer"],
197 ['nvsize', "Double"]) {
198 my ($key, $name) = @$_;
200 substr ($copy, $where++, 1) = chr 0;
201 test_corrupt ($copy, $sub, "/^$name size is not compatible/",
205 $where = $file_magic + $network_magic;
208 # Just the header and a tag 255. As 28 is currently the highest tag, this
210 $copy = substr ($contents, 0, $where) . chr 255;
212 test_corrupt ($copy, $sub,
213 "/^Corrupted storable $what \\(binary v$header->{major}.$header->{minor}\\)/",
216 # Now drop the minor version number
217 substr ($copy, $file_magic + 1, 1) = chr $minor1;
219 test_corrupt ($copy, $sub,
220 "/^Corrupted storable $what \\(binary v$header->{major}.$minor1\\)/",
221 "bogus tag, minor less 1");
222 # Now increase the minor version number
223 substr ($copy, $file_magic + 1, 1) = chr $minor4;
225 # local $Storable::DEBUGME = 1;
226 # This is the delayed croak
227 test_corrupt ($copy, $sub,
228 "/^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 28/",
229 "bogus tag, minor plus 4");
230 # And check again that this croak is not delayed:
232 # local $Storable::DEBUGME = 1;
233 local $Storable::accept_future_minor = 0;
234 test_corrupt ($copy, $sub,
235 "/^Storable binary image v$header->{major}\.$minor4 more recent than I am \\(v$header->{major}\.$minor\\)/",
240 ok (defined store(\%hash, $file));
242 my $expected = 20 + length ($file_magic_str) + $other_magic + $fancy;
243 my $length = -s $file;
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 long is $Config{longsize}) but it is $length"
249 unless $length == $expected;
251 # Read the contents into memory:
252 my $contents = slurp ($file);
254 # Test the original direct from disk
255 my $clone = retrieve $file;
259 test_things($contents, \&store_and_retrieve, 'file');
261 # And now try almost everything again with a Storable string
262 my $stored = freeze \%hash;
263 test_things($stored, \&freeze_and_thaw, 'string');
266 unlink $file or die "Can't unlink '$file': $!";
268 ok (defined nstore(\%hash, $file));
270 $expected = 20 + length ($file_magic_str) + $network_magic + $fancy;
273 die "Don't seem to have written file '$file' as I can't get its length: $!"
274 unless defined $file;
276 die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
277 unless $length == $expected;
279 # Read the contents into memory:
280 $contents = slurp ($file);
282 # Test the original direct from disk
283 $clone = retrieve $file;
287 test_things($contents, \&store_and_retrieve, 'file', 1);
289 # And now try almost everything again with a Storable string
290 $stored = nfreeze \%hash;
291 test_things($stored, \&freeze_and_thaw, 'string', 1);
293 # Test that the bug fixed by #20587 doesn't affect us under some older
296 chop(my $a = chr(0xDF).chr(256));
297 my %a = (chr(0xDF) => 1);
300 # If we were built with -DDEBUGGING, the assert() should have killed
301 # us, which will probably alert the user that something went wrong.
305 # Unusual in that the empty string is stored with an SX_LSCALAR marker
306 my $hash = store_and_retrieve("pst0\5\6\3\0\0\0\1\1\0\0\0\0\0\0\0\5empty");
307 ok(!$@, "no exception");
308 is(ref($hash), "HASH", "got a hash");
309 is($hash->{empty}, "", "got empty element");