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
  35 # header size depends on the size of the byteorder string
  36 $file_magic_str = 'pst0';
  37 $other_magic = 7 + length($Config{byteorder});
  38 $network_magic = 2;
  39 $major = 2;
  40 $minor = 5;
  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, "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   my $minor1 = $header->{minor} + 1;
 152   substr ($copy, $file_magic + 1, 1) = chr $minor1;
 153   test_corrupt ($copy, $sub,
 154                 "/^Storable binary image v$header->{major}\.$minor1 more recent than I am \\(v$header->{major}\.$header->{minor}\\)/",
 155                 "higher minor");
 156
 157   $copy = $contents;
 158   my $major1 = $header->{major} + 1;
 159   substr ($copy, $file_magic, 1) = chr 2*$major1;
 160   test_corrupt ($copy, $sub,
 161                 "/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$header->{minor}\\)/",
 162                 "higher major");
 163
 164   # Continue messing with the previous copy
 165   $minor1 = $header->{minor} - 1;
 166   substr ($copy, $file_magic + 1, 1) = chr $minor1;
 167   test_corrupt ($copy, $sub,
 168                 "/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$header->{minor}\\)/",
 169               "higher major, lower minor");
 170
 171   my $where;
 172   if (!$isnetwork) {
 173     # All these are omitted from the network order header.
 174     # I'm not sure if it's correct to omit the byte size stuff.
 175     $copy = $contents;
 176     substr ($copy, $file_magic + 3, length $header->{byteorder})
 177       = reverse $header->{byteorder};
 178
 179     test_corrupt ($copy, $sub, "/^Byte order is not compatible/",
 180                   "byte order");
 181     $where = $file_magic + 3 + length $header->{byteorder};
 182     foreach (['intsize', "Integer"],
 183              ['longsize', "Long integer"],
 184              ['ptrsize', "Pointer integer"],
 185              ['nvsize', "Double"]) {
 186       my ($key, $name) = @$_;
 187       $copy = $contents;
 188       substr ($copy, $where++, 1) = chr 0;
 189       test_corrupt ($copy, $sub, "/^$name size is not compatible/",
 190                     "$name size");
 191     }
 192   } else {
 193     $where = $file_magic + $network_magic;
 194   }
 195
 196   # Just the header and a tag 255. As 26 is currently the highest tag, this
 197   # is "unexpected"
 198   $copy = substr ($contents, 0, $where) . chr 255;
 199
 200   test_corrupt ($copy, $sub,
 201                 "/^Corrupted storable $what \\(binary v$header->{major}.$header->{minor}\\)/",
 202                 "bogus tag");
 203 }
 204
 205 sub slurp {
 206   my $file = shift;
 207   local (*FH, $/);
 208   open FH, "<$file" or die "Can't open '$file': $!";
 209   binmode FH;
 210   my $contents = <FH>;
 211   die "Can't read $file: $!" unless defined $contents;
 212   return $contents;
 213 }
 214
 215
 216 ok (defined store(\%hash, $file));
 217
 218 my $expected = 20 + length ($file_magic_str) + $other_magic;
 219 my $length = -s $file;
 220
 221 die "Don't seem to have written file '$file' as I can't get its length: $!"
 222   unless defined $file;
 223
 224 die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
 225   unless $length == $expected;
 226
 227 # Read the contents into memory:
 228 my $contents = slurp $file;
 229
 230 # Test the original direct from disk
 231 my $clone = retrieve $file;
 232 test_hash ($clone);
 233
 234 # Then test it.
 235 test_things($contents, \&store_and_retrieve, 'file');
 236
 237 # And now try almost everything again with a Storable string
 238 my $stored = freeze \%hash;
 239 test_things($stored, \&freeze_and_thaw, 'string');
 240
 241 # Network order.
 242 unlink $file or die "Can't unlink '$file': $!";
 243
 244 ok (defined nstore(\%hash, $file));
 245
 246 $expected = 20 + length ($file_magic_str) + $network_magic;
 247 $length = -s $file;
 248
 249 die "Don't seem to have written file '$file' as I can't get its length: $!"
 250   unless defined $file;
 251
 252 die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
 253   unless $length == $expected;
 254
 255 # Read the contents into memory:
 256 $contents = slurp $file;
 257
 258 # Test the original direct from disk
 259 $clone = retrieve $file;
 260 test_hash ($clone);
 261
 262 # Then test it.
 263 test_things($contents, \&store_and_retrieve, 'file', 1);
 264
 265 # And now try almost everything again with a Storable string
 266 $stored = nfreeze \%hash;
 267 test_things($stored, \&freeze_and_thaw, 'string', 1);