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
  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
  17 sub BEGIN {
  18     if ($ENV{PERL_CORE}){
  19         chdir('t') if -d 't';
  20         @INC = ('.', '../lib');
  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     }
  27 }
  28
  29 use strict;
  30 use vars qw($file_magic_str $other_magic $network_magic $byteorder
  31             $major $minor $minor_write $fancy);
  32
  33 $byteorder = $Config{byteorder};
  34
  35 if ($] < 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
  50 $file_magic_str = 'pst0';
  51 $other_magic = 7 + length $byteorder;
  52 $network_magic = 2;
  53 $major = 2;
  54 $minor = 5;
  55 $minor_write = $] > 5.007 ? 5 : 4;
  56
  57 use 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
  67 plan tests => 368 + length ($byteorder) * 4 + $fancy * 8;
  68
  69 use Storable qw (store retrieve freeze thaw nstore nfreeze);
  70
  71 my $file = "malice.$$";
  72 die "Temporary file 'malice.$$' already exists" if -e $file;
  73
  74 END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
  75
  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
  80 my %hash = (perl => 'rules', chr 256, '');
  81 delete $hash{chr 256};
  82
  83 sub test_hash {
  84   my $clone = shift;
  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");
  89 }
  90
  91 sub test_header {
  92   my ($header, $isfile, $isnetorder) = @_;
  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");
  97   if ($isnetorder) {
  98     # Network order header has no sizes
  99   } else {
 100     is ($header->{byteorder}, $byteorder, "byte order");
 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,
 105         "nv size"); # 5.00405 doesn't even have doublesize in config.
 106   }
 107 }
 108
 109 sub 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
 120 sub freeze_and_thaw {
 121   my $data = shift;
 122   return eval {thaw $data};
 123 }
 124
 125 sub 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);
 131     is (defined ($clone), '', "truncated $what to $i should fail");
 132     if ($i < $magic_len) {
 133       like ($@, "/^Magic number checking on storable $what failed/",
 134           "Should croak with magic number warning");
 135     } else {
 136       is ($@, "", "Should not set \$\@");
 137     }
 138   }
 139 }
 140
 141 sub test_corrupt {
 142   my ($data, $sub, $what, $name) = @_;
 143
 144   my $clone = &$sub($data);
 145   is (defined ($clone), '', "$name $what should fail");
 146   like ($@, $what, $name);
 147 }
 148
 149 sub 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
 160   is ($@, "", "There should be no error");
 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;
 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;
 189   {
 190     # Now by default newer minor version numbers are not a pain.
 191     $clone = &$sub($copy);
 192     is ($@, "", "by default no error on higher minor");
 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   }
 200
 201   $copy = $contents;
 202   my $major1 = $header->{major} + 1;
 203   substr ($copy, $file_magic, 1) = chr 2*$major1;
 204   test_corrupt ($copy, $sub,
 205                 "/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$minor\\)/",
 206                 "higher major");
 207
 208   # Continue messing with the previous copy
 209   my $minor1 = $header->{minor} - 1;
 210   substr ($copy, $file_magic + 1, 1) = chr $minor1;
 211   test_corrupt ($copy, $sub,
 212                 "/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$minor\\)/",
 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"],
 227              ['longsize', "Long integer"],
 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");
 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,
 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/",
 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   }
 270 }
 271
 272 sub 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
 283 ok (defined store(\%hash, $file));
 284
 285 my $expected = 20 + length ($file_magic_str) + $other_magic + $fancy;
 286 my $length = -s $file;
 287
 288 die "Don't seem to have written file '$file' as I can't get its length: $!"
 289   unless defined $file;
 290
 291 die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
 292   unless $length == $expected;
 293
 294 # Read the contents into memory:
 295 my $contents = slurp $file;
 296
 297 # Test the original direct from disk
 298 my $clone = retrieve $file;
 299 test_hash ($clone);
 300
 301 # Then test it.
 302 test_things($contents, \&store_and_retrieve, 'file');
 303
 304 # And now try almost everything again with a Storable string
 305 my $stored = freeze \%hash;
 306 test_things($stored, \&freeze_and_thaw, 'string');
 307
 308 # Network order.
 309 unlink $file or die "Can't unlink '$file': $!";
 310
 311 ok (defined nstore(\%hash, $file));
 312
 313 $expected = 20 + length ($file_magic_str) + $network_magic + $fancy;
 314 $length = -s $file;
 315
 316 die "Don't seem to have written file '$file' as I can't get its length: $!"
 317   unless defined $file;
 318
 319 die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
 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;
 327 test_hash ($clone);
 328
 329 # Then test it.
 330 test_things($contents, \&store_and_retrieve, 'file', 1);
 331
 332 # And now try almost everything again with a Storable string
 333 $stored = nfreeze \%hash;
 334 test_things($stored, \&freeze_and_thaw, 'string', 1);