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