ext/Storable/t/malice.t

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