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