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