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