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