Remove $Id$ lines.
[p5sagit/p5-mst-13.2.git] / ext / Storable / t / malice.t
CommitLineData
b8778c7c 1#!./perl -w
b8778c7c 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//;
b8778c7c 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
16sub BEGIN {
17 if ($ENV{PERL_CORE}){
18 chdir('t') if -d 't';
372cb964 19 @INC = ('.', '../lib');
b8778c7c 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 }
b8778c7c 26}
27
28use strict;
677a847b 29use vars qw($file_magic_str $other_magic $network_magic $byteorder
30 $major $minor $minor_write $fancy);
31
32$byteorder = $Config{byteorder};
33
96ef0061 34$file_magic_str = 'pst0';
677a847b 35$other_magic = 7 + length $byteorder;
96ef0061 36$network_magic = 2;
37$major = 2;
38$minor = 5;
530b72ba 39$minor_write = $] > 5.007 ? 5 : 4;
b8778c7c 40
372cb964 41use 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
677a847b 51plan tests => 368 + length ($byteorder) * 4 + $fancy * 8;
b8778c7c 52
53use Storable qw (store retrieve freeze thaw nstore nfreeze);
54
55my $file = "malice.$$";
56die "Temporary file 'malice.$$' already exists" if -e $file;
57
58END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
59
9d80fab7 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
64my %hash = (perl => 'rules', chr 256, '');
65delete $hash{chr 256};
b8778c7c 66
67sub test_hash {
68 my $clone = shift;
372cb964 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");
b8778c7c 73}
74
75sub test_header {
76 my ($header, $isfile, $isnetorder) = @_;
372cb964 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");
677a847b 81 if ($isnetorder) {
82 # Network order header has no sizes
83 } else {
84 is ($header->{byteorder}, $byteorder, "byte order");
372cb964 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,
b8778c7c 89 "nv size"); # 5.00405 doesn't even have doublesize in config.
90 }
91}
92
93sub 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
104sub freeze_and_thaw {
105 my $data = shift;
106 return eval {thaw $data};
107}
108
109sub 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);
372cb964 115 is (defined ($clone), '', "truncated $what to $i should fail");
b8778c7c 116 if ($i < $magic_len) {
372cb964 117 like ($@, "/^Magic number checking on storable $what failed/",
b8778c7c 118 "Should croak with magic number warning");
119 } else {
372cb964 120 is ($@, "", "Should not set \$\@");
b8778c7c 121 }
122 }
123}
124
125sub test_corrupt {
126 my ($data, $sub, $what, $name) = @_;
127
128 my $clone = &$sub($data);
372cb964 129 is (defined ($clone), '', "$name $what should fail");
130 like ($@, $what, $name);
b8778c7c 131}
132
133sub 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
372cb964 144 is ($@, "", "There should be no error");
b8778c7c 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;
530b72ba 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;
e8189732 173 {
174 # Now by default newer minor version numbers are not a pain.
175 $clone = &$sub($copy);
372cb964 176 is ($@, "", "by default no error on higher minor");
e8189732 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 }
b8778c7c 184
185 $copy = $contents;
186 my $major1 = $header->{major} + 1;
187 substr ($copy, $file_magic, 1) = chr 2*$major1;
188 test_corrupt ($copy, $sub,
530b72ba 189 "/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$minor\\)/",
b8778c7c 190 "higher major");
191
192 # Continue messing with the previous copy
530b72ba 193 my $minor1 = $header->{minor} - 1;
b8778c7c 194 substr ($copy, $file_magic + 1, 1) = chr $minor1;
195 test_corrupt ($copy, $sub,
530b72ba 196 "/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$minor\\)/",
b8778c7c 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"],
291cf09c 211 ['longsize', "Long integer"],
b8778c7c 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");
e8189732 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,
0ba8809e 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 25/",
e8189732 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 }
b8778c7c 254}
255
256sub 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
267ok (defined store(\%hash, $file));
268
9d80fab7 269my $expected = 20 + length ($file_magic_str) + $other_magic + $fancy;
b8778c7c 270my $length = -s $file;
271
272die "Don't seem to have written file '$file' as I can't get its length: $!"
273 unless defined $file;
274
291cf09c 275die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
b8778c7c 276 unless $length == $expected;
277
278# Read the contents into memory:
279my $contents = slurp $file;
280
281# Test the original direct from disk
282my $clone = retrieve $file;
283test_hash ($clone);
284
285# Then test it.
286test_things($contents, \&store_and_retrieve, 'file');
287
288# And now try almost everything again with a Storable string
289my $stored = freeze \%hash;
290test_things($stored, \&freeze_and_thaw, 'string');
291
292# Network order.
293unlink $file or die "Can't unlink '$file': $!";
294
295ok (defined nstore(\%hash, $file));
296
9d80fab7 297$expected = 20 + length ($file_magic_str) + $network_magic + $fancy;
b8778c7c 298$length = -s $file;
299
300die "Don't seem to have written file '$file' as I can't get its length: $!"
301 unless defined $file;
302
291cf09c 303die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
b8778c7c 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;
311test_hash ($clone);
312
313# Then test it.
314test_things($contents, \&store_and_retrieve, 'file', 1);
315
316# And now try almost everything again with a Storable string
317$stored = nfreeze \%hash;
318test_things($stored, \&freeze_and_thaw, 'string', 1);