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);
  34 $file_magic_str = 'pst0';
  35 $other_magic = 7 + $Config{longsize};
  36 $network_magic = 2;
  37
  38 use Test;
  39 BEGIN { plan tests => 334 + $Config{longsize} * 4}
  40
  41 use Storable qw (store retrieve freeze thaw nstore nfreeze);
  42
  43 my $file = "malice.$$";
  44 die "Temporary file 'malice.$$' already exists" if -e $file;
  45
  46 END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
  47
  48 my %hash = (perl => 'rules');
  49
  50 sub test_hash {
  51   my $clone = shift;
  52   ok (ref $clone, "HASH", "Get hash back");
  53   ok (scalar keys %$clone, 1, "with 1 key");
  54   ok ((keys %$clone)[0], "perl", "which is correct");
  55   ok ($clone->{perl}, "rules");
  56 }
  57
  58 sub test_header {
  59   my ($header, $isfile, $isnetorder) = @_;
  60   ok (!!$header->{file}, !!$isfile, "is file");
  61   ok ($header->{major}, 2, "major number");
  62   ok ($header->{minor}, 5, "minor number");
  63   ok (!!$header->{netorder}, !!$isnetorder, "is network order");
  64   if ($isnetorder) {
  65     # Skip these
  66     for (1..5) {
  67       ok (1, 1, "Network order header has no sizes");
  68     }
  69   } else {
  70     ok ($header->{byteorder}, $Config{byteorder}, "byte order");
  71     ok ($header->{intsize}, $Config{intsize}, "int size");
  72     ok ($header->{longsize}, $Config{longsize}, "long size");
  73     ok ($header->{ptrsize}, $Config{ptrsize}, "long size");
  74     ok ($header->{nvsize}, $Config{nvsize} || $Config{doublesize} || 8,
  75         "nv size"); # 5.00405 doesn't even have doublesize in config.
  76   }
  77 }
  78
  79 sub store_and_retrieve {
  80   my $data = shift;
  81   unlink $file or die "Can't unlink '$file': $!";
  82   open FH, ">$file" or die "Can't open '$file': $!";
  83   binmode FH;
  84   print FH $data or die "Can't print to '$file': $!";
  85   close FH or die "Can't close '$file': $!";
  86
  87   return  eval {retrieve $file};
  88 }
  89
  90 sub freeze_and_thaw {
  91   my $data = shift;
  92   return eval {thaw $data};
  93 }
  94
  95 sub test_truncated {
  96   my ($data, $sub, $magic_len, $what) = @_;
  97   for my $i (0 .. length ($data) - 1) {
  98     my $short = substr $data, 0, $i;
  99
 100     my $clone = &$sub($short);
 101     ok (defined ($clone), '', "truncated $what to $i should fail");
 102     if ($i < $magic_len) {
 103       ok ($@, "/^Magic number checking on storable $what failed/",
 104           "Should croak with magic number warning");
 105     } else {
 106       ok ($@, "", "Should not set \$\@");
 107     }
 108   }
 109 }
 110
 111 sub test_corrupt {
 112   my ($data, $sub, $what, $name) = @_;
 113
 114   my $clone = &$sub($data);
 115   ok (defined ($clone), '', "$name $what should fail");
 116   ok ($@, $what, $name);
 117 }
 118
 119 sub test_things {
 120   my ($contents, $sub, $what, $isnetwork) = @_;
 121   my $isfile = $what eq 'file';
 122   my $file_magic = $isfile ? length $file_magic_str : 0;
 123
 124   my $header = Storable::read_magic ($contents);
 125   test_header ($header, $isfile, $isnetwork);
 126
 127   # Test that if we re-write it, everything still works:
 128   my $clone = &$sub ($contents);
 129
 130   ok ($@, "", "There should be no error");
 131
 132   test_hash ($clone);
 133
 134   # Now lets check the short version:
 135   test_truncated ($contents, $sub, $file_magic
 136                   + ($isnetwork ? $network_magic : $other_magic), $what);
 137
 138   my $copy;
 139   if ($isfile) {
 140     $copy = $contents;
 141     substr ($copy, 0, 4) = 'iron';
 142     test_corrupt ($copy, $sub, "/^File is not a perl storable/",
 143                   "magic number");
 144   }
 145
 146   $copy = $contents;
 147   my $minor1 = $header->{minor} + 1;
 148   substr ($copy, $file_magic + 1, 1) = chr $minor1;
 149   test_corrupt ($copy, $sub,
 150                 "/^Storable binary image v$header->{major}.$minor1 more recent than I am \\(v$header->{major}.$header->{minor}\\)/",
 151                 "higher minor");
 152
 153   $copy = $contents;
 154   my $major1 = $header->{major} + 1;
 155   substr ($copy, $file_magic, 1) = chr 2*$major1;
 156   test_corrupt ($copy, $sub,
 157                 "/^Storable binary image v$major1.$header->{minor} more recent than I am \\(v$header->{major}.$header->{minor}\\)/",
 158                 "higher major");
 159
 160   # Continue messing with the previous copy
 161   $minor1 = $header->{minor} - 1;
 162   substr ($copy, $file_magic + 1, 1) = chr $minor1;
 163   test_corrupt ($copy, $sub,
 164                 "/^Storable binary image v$major1.$minor1 more recent than I am \\(v$header->{major}.$header->{minor}\\)/",
 165               "higher major, lower minor");
 166
 167   my $where;
 168   if (!$isnetwork) {
 169     # All these are omitted from the network order header.
 170     # I'm not sure if it's correct to omit the byte size stuff.
 171     $copy = $contents;
 172     substr ($copy, $file_magic + 3, length $header->{byteorder})
 173       = reverse $header->{byteorder};
 174
 175     test_corrupt ($copy, $sub, "/^Byte order is not compatible/",
 176                   "byte order");
 177     $where = $file_magic + 3 + length $header->{byteorder};
 178     foreach (['intsize', "Integer"],
 179              ['longsize', "Long integer"],
 180              ['ptrsize', "Pointer integer"],
 181              ['nvsize', "Double"]) {
 182       my ($key, $name) = @$_;
 183       $copy = $contents;
 184       substr ($copy, $where++, 1) = chr 0;
 185       test_corrupt ($copy, $sub, "/^$name size is not compatible/",
 186                     "$name size");
 187     }
 188   } else {
 189     $where = $file_magic + $network_magic;
 190   }
 191
 192   # Just the header and a tag 255. As 26 is currently the highest tag, this
 193   # is "unexpected"
 194   $copy = substr ($contents, 0, $where) . chr 255;
 195
 196   test_corrupt ($copy, $sub,
 197                 "/^Corrupted storable $what \\(binary v$header->{major}.$header->{minor}\\)/",
 198                 "bogus tag");
 199 }
 200
 201 sub slurp {
 202   my $file = shift;
 203   local (*FH, $/);
 204   open FH, "<$file" or die "Can't open '$file': $!";
 205   binmode FH;
 206   my $contents = <FH>;
 207   die "Can't read $file: $!" unless defined $contents;
 208   return $contents;
 209 }
 210
 211
 212 ok (defined store(\%hash, $file));
 213
 214 my $expected = 20 + length ($file_magic_str) + $other_magic;
 215 my $length = -s $file;
 216
 217 die "Don't seem to have written file '$file' as I can't get its length: $!"
 218   unless defined $file;
 219
 220 die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
 221   unless $length == $expected;
 222
 223 # Read the contents into memory:
 224 my $contents = slurp $file;
 225
 226 # Test the original direct from disk
 227 my $clone = retrieve $file;
 228 test_hash ($clone);
 229
 230 # Then test it.
 231 test_things($contents, \&store_and_retrieve, 'file');
 232
 233 # And now try almost everything again with a Storable string
 234 my $stored = freeze \%hash;
 235 test_things($stored, \&freeze_and_thaw, 'string');
 236
 237 # Network order.
 238 unlink $file or die "Can't unlink '$file': $!";
 239
 240 ok (defined nstore(\%hash, $file));
 241
 242 $expected = 20 + length ($file_magic_str) + $network_magic;
 243 $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 $contents = slurp $file;
 253
 254 # Test the original direct from disk
 255 $clone = retrieve $file;
 256 test_hash ($clone);
 257
 258 # Then test it.
 259 test_things($contents, \&store_and_retrieve, 'file', 1);
 260
 261 # And now try almost everything again with a Storable string
 262 $stored = nfreeze \%hash;
 263 test_things($stored, \&freeze_and_thaw, 'string', 1);