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