ext/Storable/t/malice.t

   1 #!./perl -w
   2 #
   3 #  Copyright 2002, Larry Wall.
   4 #
   5 #  You may redistribute only under the same terms as Perl 5, as specified
   6 #  in the README file that comes with the distribution.
   7 #
   8
   9 # I'm trying to keep this test easily backwards compatible to 5.004, so no
  10 # qr//;
  11
  12 # This test tries to craft malicious data to test out as many different
  13 # error traps in Storable as possible
  14 # It also acts as a test for read_header
  15
  16 sub BEGIN {
  17     if ($ENV{PERL_CORE}){
  18         chdir('t') if -d 't';
  19         @INC = ('.', '../lib');
  20     } else {
  21         # This lets us distribute Test::More in t/
  22         unshift @INC, 't';
  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 }
  30
  31 use strict;
  32 use vars qw($file_magic_str $other_magic $network_magic $byteorder
  33             $major $minor $minor_write $fancy);
  34
  35 $byteorder = $Config{byteorder};
  36
  37 $file_magic_str = 'pst0';
  38 $other_magic = 7 + length $byteorder;
  39 $network_magic = 2;
  40 $major = 2;
  41 $minor = 6;
  42 $minor_write = $] > 5.007 ? 6 : 4;
  43
  44 use Test::More;
  45
  46 # If it's 5.7.3 or later the hash will be stored with flags, which is
  47 # 2 extra bytes. There are 2 * 2 * 2 tests per byte in the body and header
  48 # common to normal and network order serialised objects (hence the 8)
  49 # There are only 2 * 2 tests per byte in the parts of the header not present
  50 # for network order, and 2 tests per byte on the 'pst0' "magic number" only
  51 # present in files, but not in things store()ed to memory
  52 $fancy = ($] > 5.007 ? 2 : 0);
  53
  54 plan tests => 368 + length ($byteorder) * 4 + $fancy * 8;
  55
  56 use Storable qw (store retrieve freeze thaw nstore nfreeze);
  57
  58 my $file = "malice.$$";
  59 die "Temporary file 'malice.$$' already exists" if -e $file;
  60
  61 END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
  62
  63 # The chr 256 is a hack to force the hash to always have the utf8 keys flag
  64 # set on 5.7.3 and later. Otherwise the test fails if run with -Mutf8 because
  65 # only there does the hash has the flag on, and hence only there is it stored
  66 # as a flagged hash, which is 2 bytes longer
  67 my %hash = (perl => 'rules', chr 256, '');
  68 delete $hash{chr 256};
  69
  70 sub test_hash {
  71   my $clone = shift;
  72   is (ref $clone, "HASH", "Get hash back");
  73   is (scalar keys %$clone, 1, "with 1 key");
  74   is ((keys %$clone)[0], "perl", "which is correct");
  75   is ($clone->{perl}, "rules");
  76 }
  77
  78 sub test_header {
  79   my ($header, $isfile, $isnetorder) = @_;
  80   is (!!$header->{file}, !!$isfile, "is file");
  81   is ($header->{major}, $major, "major number");
  82   is ($header->{minor}, $minor_write, "minor number");
  83   is (!!$header->{netorder}, !!$isnetorder, "is network order");
  84   if ($isnetorder) {
  85     # Network order header has no sizes
  86   } else {
  87     is ($header->{byteorder}, $byteorder, "byte order");
  88     is ($header->{intsize}, $Config{intsize}, "int size");
  89     is ($header->{longsize}, $Config{longsize}, "long size");
  90  SKIP: {
  91         skip ("No \$Config{prtsize} on this perl version ($])", 1)
  92             unless defined $Config{ptrsize};
  93         is ($header->{ptrsize}, $Config{ptrsize}, "long size");
  94     }
  95     is ($header->{nvsize}, $Config{nvsize} || $Config{doublesize} || 8,
  96         "nv size"); # 5.00405 doesn't even have doublesize in config.
  97   }
  98 }
  99
 100 sub store_and_retrieve {
 101   my $data = shift;
 102   unlink $file or die "Can't unlink '$file': $!";
 103   open FH, ">$file" or die "Can't open '$file': $!";
 104   binmode FH;
 105   print FH $data or die "Can't print to '$file': $!";
 106   close FH or die "Can't close '$file': $!";
 107
 108   return  eval {retrieve $file};
 109 }
 110
 111 sub freeze_and_thaw {
 112   my $data = shift;
 113   return eval {thaw $data};
 114 }
 115
 116 sub test_truncated {
 117   my ($data, $sub, $magic_len, $what) = @_;
 118   for my $i (0 .. length ($data) - 1) {
 119     my $short = substr $data, 0, $i;
 120
 121     # local $Storable::DEBUGME = 1;
 122     my $clone = &$sub($short);
 123     is (defined ($clone), '', "truncated $what to $i should fail");
 124     if ($i < $magic_len) {
 125       like ($@, "/^Magic number checking on storable $what failed/",
 126           "Should croak with magic number warning");
 127     } else {
 128       is ($@, "", "Should not set \$\@");
 129     }
 130   }
 131 }
 132
 133 sub test_corrupt {
 134   my ($data, $sub, $what, $name) = @_;
 135
 136   my $clone = &$sub($data);
 137   is (defined ($clone), '', "$name $what should fail");
 138   like ($@, $what, $name);
 139 }
 140
 141 sub test_things {
 142   my ($contents, $sub, $what, $isnetwork) = @_;
 143   my $isfile = $what eq 'file';
 144   my $file_magic = $isfile ? length $file_magic_str : 0;
 145
 146   my $header = Storable::read_magic ($contents);
 147   test_header ($header, $isfile, $isnetwork);
 148
 149   # Test that if we re-write it, everything still works:
 150   my $clone = &$sub ($contents);
 151
 152   is ($@, "", "There should be no error");
 153
 154   test_hash ($clone);
 155
 156   # Now lets check the short version:
 157   test_truncated ($contents, $sub, $file_magic
 158                   + ($isnetwork ? $network_magic : $other_magic), $what);
 159
 160   my $copy;
 161   if ($isfile) {
 162     $copy = $contents;
 163     substr ($copy, 0, 4) = 'iron';
 164     test_corrupt ($copy, $sub, "/^File is not a perl storable/",
 165                   "magic number");
 166   }
 167
 168   $copy = $contents;
 169   # Needs to be more than 1, as we're already coding a spread of 1 minor version
 170   # number on writes (2.5, 2.4). May increase to 2 if we figure we can do 2.3
 171   # on 5.005_03 (No utf8).
 172   # 4 allows for a small safety margin
 173   # (Joke:
 174   # Question: What is the value of pi?
 175   # Mathematician answers "It's pi, isn't it"
 176   # Physicist answers "3.1, within experimental error"
 177   # Engineer answers "Well, allowing for a small safety margin,   18"
 178   # )
 179   my $minor4 = $header->{minor} + 4;
 180   substr ($copy, $file_magic + 1, 1) = chr $minor4;
 181   {
 182     # Now by default newer minor version numbers are not a pain.
 183     $clone = &$sub($copy);
 184     is ($@, "", "by default no error on higher minor");
 185     test_hash ($clone);
 186
 187     local $Storable::accept_future_minor = 0;
 188     test_corrupt ($copy, $sub,
 189                   "/^Storable binary image v$header->{major}\.$minor4 more recent than I am \\(v$header->{major}\.$minor\\)/",
 190                   "higher minor");
 191   }
 192
 193   $copy = $contents;
 194   my $major1 = $header->{major} + 1;
 195   substr ($copy, $file_magic, 1) = chr 2*$major1;
 196   test_corrupt ($copy, $sub,
 197                 "/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$minor\\)/",
 198                 "higher major");
 199
 200   # Continue messing with the previous copy
 201   my $minor1 = $header->{minor} - 1;
 202   substr ($copy, $file_magic + 1, 1) = chr $minor1;
 203   test_corrupt ($copy, $sub,
 204                 "/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$minor\\)/",
 205               "higher major, lower minor");
 206
 207   my $where;
 208   if (!$isnetwork) {
 209     # All these are omitted from the network order header.
 210     # I'm not sure if it's correct to omit the byte size stuff.
 211     $copy = $contents;
 212     substr ($copy, $file_magic + 3, length $header->{byteorder})
 213       = reverse $header->{byteorder};
 214
 215     test_corrupt ($copy, $sub, "/^Byte order is not compatible/",
 216                   "byte order");
 217     $where = $file_magic + 3 + length $header->{byteorder};
 218     foreach (['intsize', "Integer"],
 219              ['longsize', "Long integer"],
 220              ['ptrsize', "Pointer"],
 221              ['nvsize', "Double"]) {
 222       my ($key, $name) = @$_;
 223       $copy = $contents;
 224       substr ($copy, $where++, 1) = chr 0;
 225       test_corrupt ($copy, $sub, "/^$name size is not compatible/",
 226                     "$name size");
 227     }
 228   } else {
 229     $where = $file_magic + $network_magic;
 230   }
 231
 232   # Just the header and a tag 255. As 26 is currently the highest tag, this
 233   # is "unexpected"
 234   $copy = substr ($contents, 0, $where) . chr 255;
 235
 236   test_corrupt ($copy, $sub,
 237                 "/^Corrupted storable $what \\(binary v$header->{major}.$header->{minor}\\)/",
 238                 "bogus tag");
 239
 240   # Now drop the minor version number
 241   substr ($copy, $file_magic + 1, 1) = chr $minor1;
 242
 243   test_corrupt ($copy, $sub,
 244                 "/^Corrupted storable $what \\(binary v$header->{major}.$minor1\\)/",
 245                 "bogus tag, minor less 1");
 246   # Now increase the minor version number
 247   substr ($copy, $file_magic + 1, 1) = chr $minor4;
 248
 249   # local $Storable::DEBUGME = 1;
 250   # This is the delayed croak
 251   test_corrupt ($copy, $sub,
 252                 "/^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 26/",
 253                 "bogus tag, minor plus 4");
 254   # And check again that this croak is not delayed:
 255   {
 256     # local $Storable::DEBUGME = 1;
 257     local $Storable::accept_future_minor = 0;
 258     test_corrupt ($copy, $sub,
 259                   "/^Storable binary image v$header->{major}\.$minor4 more recent than I am \\(v$header->{major}\.$minor\\)/",
 260                   "higher minor");
 261   }
 262 }
 263
 264 sub slurp {
 265   my $file = shift;
 266   local (*FH, $/);
 267   open FH, "<$file" or die "Can't open '$file': $!";
 268   binmode FH;
 269   my $contents = <FH>;
 270   die "Can't read $file: $!" unless defined $contents;
 271   return $contents;
 272 }
 273
 274
 275 ok (defined store(\%hash, $file));
 276
 277 my $expected = 20 + length ($file_magic_str) + $other_magic + $fancy;
 278 my $length = -s $file;
 279
 280 die "Don't seem to have written file '$file' as I can't get its length: $!"
 281   unless defined $file;
 282
 283 die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
 284   unless $length == $expected;
 285
 286 # Read the contents into memory:
 287 my $contents = slurp $file;
 288
 289 # Test the original direct from disk
 290 my $clone = retrieve $file;
 291 test_hash ($clone);
 292
 293 # Then test it.
 294 test_things($contents, \&store_and_retrieve, 'file');
 295
 296 # And now try almost everything again with a Storable string
 297 my $stored = freeze \%hash;
 298 test_things($stored, \&freeze_and_thaw, 'string');
 299
 300 # Network order.
 301 unlink $file or die "Can't unlink '$file': $!";
 302
 303 ok (defined nstore(\%hash, $file));
 304
 305 $expected = 20 + length ($file_magic_str) + $network_magic + $fancy;
 306 $length = -s $file;
 307
 308 die "Don't seem to have written file '$file' as I can't get its length: $!"
 309   unless defined $file;
 310
 311 die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
 312   unless $length == $expected;
 313
 314 # Read the contents into memory:
 315 $contents = slurp $file;
 316
 317 # Test the original direct from disk
 318 $clone = retrieve $file;
 319 test_hash ($clone);
 320
 321 # Then test it.
 322 test_things($contents, \&store_and_retrieve, 'file', 1);
 323
 324 # And now try almost everything again with a Storable string
 325 $stored = nfreeze \%hash;
 326 test_things($stored, \&freeze_and_thaw, 'string', 1);