This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ffc9fcf54f3c69d41167e11b5220fc6e1c78d2e6
[perl5.git] / dist / Storable / t / malice.t
1 #!./perl -w
2 #
3 #  Copyright 2002, Larry Wall.
4 #
5 #  You may redistribute only under the same terms as Perl 5, as specified
6 #  in the README file that comes with the distribution.
7 #
8
9 # I'm trying to keep this test easily backwards compatible to 5.004, so no
10 # qr//;
11
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
15
16 sub BEGIN {
17     # This lets us distribute Test::More in t/
18     unshift @INC, 't';
19     unshift @INC, 't/compat' if $] < 5.006002;
20     require Config; import Config;
21     if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
22         print "1..0 # Skip: Storable was not built\n";
23         exit 0;
24     }
25 }
26
27 use strict;
28 use vars qw($file_magic_str $other_magic $network_magic $byteorder
29             $major $minor $minor_write $fancy);
30
31 $byteorder = $Config{byteorder};
32
33 $file_magic_str = 'pst0';
34 $other_magic = 7 + length $byteorder;
35 $network_magic = 2;
36 $major = 2;
37 $minor = 9;
38 $minor_write = $] > 5.008 ? 9 : $] > 5.005_50 ? 8 : 4;
39
40 use Test::More;
41
42 # If it's 5.7.3 or later the hash will be stored with flags, which is
43 # 2 extra bytes. There are 2 * 2 * 2 tests per byte in the body and header
44 # common to normal and network order serialised objects (hence the 8)
45 # There are only 2 * 2 tests per byte in the parts of the header not present
46 # for network order, and 2 tests per byte on the 'pst0' "magic number" only
47 # present in files, but not in things store()ed to memory
48 $fancy = ($] > 5.007 ? 2 : 0);
49
50 plan tests => 372 + length ($byteorder) * 4 + $fancy * 8;
51
52 use Storable qw (store retrieve freeze thaw nstore nfreeze);
53 require 'testlib.pl';
54 use vars '$file';
55
56 # The chr 256 is a hack to force the hash to always have the utf8 keys flag
57 # set on 5.7.3 and later. Otherwise the test fails if run with -Mutf8 because
58 # only there does the hash has the flag on, and hence only there is it stored
59 # as a flagged hash, which is 2 bytes longer
60 my %hash = (perl => 'rules', chr 256, '');
61 delete $hash{chr 256};
62
63 sub test_hash {
64   my $clone = shift;
65   is (ref $clone, "HASH", "Get hash back");
66   is (scalar keys %$clone, 1, "with 1 key");
67   is ((keys %$clone)[0], "perl", "which is correct");
68   is ($clone->{perl}, "rules");
69 }
70
71 sub test_header {
72   my ($header, $isfile, $isnetorder) = @_;
73   is (!!$header->{file}, !!$isfile, "is file");
74   is ($header->{major}, $major, "major number");
75   is ($header->{minor}, $minor_write, "minor number");
76   is (!!$header->{netorder}, !!$isnetorder, "is network order");
77   if ($isnetorder) {
78     # Network order header has no sizes
79   } else {
80     is ($header->{byteorder}, $byteorder, "byte order");
81     is ($header->{intsize}, $Config{intsize}, "int size");
82     is ($header->{longsize}, $Config{longsize}, "long size");
83  SKIP: {
84         skip ("No \$Config{prtsize} on this perl version ($])", 1)
85             unless defined $Config{ptrsize};
86         is ($header->{ptrsize}, $Config{ptrsize}, "long size");
87     }
88     is ($header->{nvsize}, $Config{nvsize} || $Config{doublesize} || 8,
89         "nv size"); # 5.00405 doesn't even have doublesize in config.
90   }
91 }
92
93 sub test_truncated {
94   my ($data, $sub, $magic_len, $what) = @_;
95   for my $i (0 .. length ($data) - 1) {
96     my $short = substr $data, 0, $i;
97
98     # local $Storable::DEBUGME = 1;
99     my $clone = &$sub($short);
100     is (defined ($clone), '', "truncated $what to $i should fail");
101     if ($i < $magic_len) {
102       like ($@, "/^Magic number checking on storable $what failed/",
103           "Should croak with magic number warning");
104     } else {
105       is ($@, "", "Should not set \$\@");
106     }
107   }
108 }
109
110 sub test_corrupt {
111   my ($data, $sub, $what, $name) = @_;
112
113   my $clone = &$sub($data);
114   local $Test::Builder::Level = $Test::Builder::Level + 1;
115   is (defined ($clone), '', "$name $what should fail");
116   like ($@, $what, $name);
117 }
118
119 sub test_things {
120   my ($contents, $sub, $what, $isnetwork) = @_;
121   my $isfile = $what eq 'file';
122   my $file_magic = $isfile ? length $file_magic_str : 0;
123
124   my $header = Storable::read_magic ($contents);
125   test_header ($header, $isfile, $isnetwork);
126
127   # Test that if we re-write it, everything still works:
128   my $clone = &$sub ($contents);
129
130   is ($@, "", "There should be no error");
131
132   test_hash ($clone);
133
134   # Now lets check the short version:
135   test_truncated ($contents, $sub, $file_magic
136                   + ($isnetwork ? $network_magic : $other_magic), $what);
137
138   my $copy;
139   if ($isfile) {
140     $copy = $contents;
141     substr ($copy, 0, 4) = 'iron';
142     test_corrupt ($copy, $sub, "/^File is not a perl storable/",
143                   "magic number");
144   }
145
146   $copy = $contents;
147   # Needs to be more than 1, as we're already coding a spread of 1 minor version
148   # number on writes (2.5, 2.4). May increase to 2 if we figure we can do 2.3
149   # on 5.005_03 (No utf8).
150   # 4 allows for a small safety margin
151   # Which we've now exhausted given that Storable 2.25 is writing 2.8
152   # (Joke:
153   # Question: What is the value of pi?
154   # Mathematician answers "It's pi, isn't it"
155   # Physicist answers "3.1, within experimental error"
156   # Engineer answers "Well, allowing for a small safety margin,   18"
157   # )
158   my $minor6 = $header->{minor} + 6;
159   substr ($copy, $file_magic + 1, 1) = chr $minor6;
160   {
161     # Now by default newer minor version numbers are not a pain.
162     $clone = &$sub($copy);
163     is ($@, "", "by default no error on higher minor");
164     test_hash ($clone);
165
166     local $Storable::accept_future_minor = 0;
167     test_corrupt ($copy, $sub,
168                   "/^Storable binary image v$header->{major}\.$minor6 more recent than I am \\(v$header->{major}\.$minor\\)/",
169                   "higher minor");
170   }
171
172   $copy = $contents;
173   my $major1 = $header->{major} + 1;
174   substr ($copy, $file_magic, 1) = chr 2*$major1;
175   test_corrupt ($copy, $sub,
176                 "/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$minor\\)/",
177                 "higher major");
178
179   # Continue messing with the previous copy
180   my $minor1 = $header->{minor} - 1;
181   substr ($copy, $file_magic + 1, 1) = chr $minor1;
182   test_corrupt ($copy, $sub,
183                 "/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$minor\\)/",
184               "higher major, lower minor");
185
186   my $where;
187   if (!$isnetwork) {
188     # All these are omitted from the network order header.
189     # I'm not sure if it's correct to omit the byte size stuff.
190     $copy = $contents;
191     substr ($copy, $file_magic + 3, length $header->{byteorder})
192       = reverse $header->{byteorder};
193
194     test_corrupt ($copy, $sub, "/^Byte order is not compatible/",
195                   "byte order");
196     $where = $file_magic + 3 + length $header->{byteorder};
197     foreach (['intsize', "Integer"],
198              ['longsize', "Long integer"],
199              ['ptrsize', "Pointer"],
200              ['nvsize', "Double"]) {
201       my ($key, $name) = @$_;
202       $copy = $contents;
203       substr ($copy, $where++, 1) = chr 0;
204       test_corrupt ($copy, $sub, "/^$name size is not compatible/",
205                     "$name size");
206     }
207   } else {
208     $where = $file_magic + $network_magic;
209   }
210
211   # Just the header and a tag 255. As 30 is currently the highest tag, this
212   # is "unexpected"
213   $copy = substr ($contents, 0, $where) . chr 255;
214
215   test_corrupt ($copy, $sub,
216                 "/^Corrupted storable $what \\(binary v$header->{major}.$header->{minor}\\)/",
217                 "bogus tag");
218
219   # Now drop the minor version number
220   substr ($copy, $file_magic + 1, 1) = chr $minor1;
221
222   test_corrupt ($copy, $sub,
223                 "/^Corrupted storable $what \\(binary v$header->{major}.$minor1\\)/",
224                 "bogus tag, minor less 1");
225   # Now increase the minor version number
226   substr ($copy, $file_magic + 1, 1) = chr $minor6;
227
228   # local $Storable::DEBUGME = 1;
229   # This is the delayed croak
230   test_corrupt ($copy, $sub,
231                 "/^Storable binary image v$header->{major}.$minor6 contains data of type 255. This Storable is v$header->{major}.$minor and can only handle data types up to 30/",
232                 "bogus tag, minor plus 4");
233   # And check again that this croak is not delayed:
234   {
235     # local $Storable::DEBUGME = 1;
236     local $Storable::accept_future_minor = 0;
237     test_corrupt ($copy, $sub,
238                   "/^Storable binary image v$header->{major}\.$minor6 more recent than I am \\(v$header->{major}\.$minor\\)/",
239                   "higher minor");
240   }
241 }
242
243 ok (defined store(\%hash, $file));
244
245 my $expected = 20 + length ($file_magic_str) + $other_magic + $fancy;
246 my $length = -s $file;
247
248 die "Don't seem to have written file '$file' as I can't get its length: $!"
249   unless defined $file;
250
251 die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
252   unless $length == $expected;
253
254 # Read the contents into memory:
255 my $contents = slurp ($file);
256
257 # Test the original direct from disk
258 my $clone = retrieve $file;
259 test_hash ($clone);
260
261 # Then test it.
262 test_things($contents, \&store_and_retrieve, 'file');
263
264 # And now try almost everything again with a Storable string
265 my $stored = freeze \%hash;
266 test_things($stored, \&freeze_and_thaw, 'string');
267
268 # Network order.
269 unlink $file or die "Can't unlink '$file': $!";
270
271 ok (defined nstore(\%hash, $file));
272
273 $expected = 20 + length ($file_magic_str) + $network_magic + $fancy;
274 $length = -s $file;
275
276 die "Don't seem to have written file '$file' as I can't get its length: $!"
277   unless defined $file;
278
279 die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
280   unless $length == $expected;
281
282 # Read the contents into memory:
283 $contents = slurp ($file);
284
285 # Test the original direct from disk
286 $clone = retrieve $file;
287 test_hash ($clone);
288
289 # Then test it.
290 test_things($contents, \&store_and_retrieve, 'file', 1);
291
292 # And now try almost everything again with a Storable string
293 $stored = nfreeze \%hash;
294 test_things($stored, \&freeze_and_thaw, 'string', 1);
295
296 # Test that the bug fixed by #20587 doesn't affect us under some older
297 # Perl. AMS 20030901
298 {
299     chop(my $a = chr(0xDF).chr(256));
300     my %a = (chr(0xDF) => 1);
301     $a{$a}++;
302     freeze \%a;
303     # If we were built with -DDEBUGGING, the assert() should have killed
304     # us, which will probably alert the user that something went wrong.
305     ok(1);
306 }
307
308 # Unusual in that the empty string is stored with an SX_LSCALAR marker
309 my $hash = store_and_retrieve("pst0\5\6\3\0\0\0\1\1\0\0\0\0\0\0\0\5empty");
310 ok(!$@, "no exception");
311 is(ref($hash), "HASH", "got a hash");
312 is($hash->{empty}, "", "got empty element");