[p5sagit/p5-mst-13.2.git] / ext / Storable / t / malice.t

#!./perl -w

#
#  Copyright 2002, Larry Wall.
#
#  You may redistribute only under the same terms as Perl 5, as specified
#  in the README file that comes with the distribution.
#

# I'm trying to keep this test easily backwards compatible to 5.004, so no
# qr//;
# Currently using Test not Test::More, as Test is in core that far back.

# This test tries to craft malicious data to test out as many different
# error traps in Storable as possible
# It also acts as a test for read_header

sub BEGIN {
    if ($ENV{PERL_CORE}){
	chdir('t') if -d 't';
	@INC = '.';
	push @INC, '../lib';
    }
    require Config; import Config;
    if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
        print "1..0 # Skip: Storable was not built\n";
        exit 0;
    }
    # require 'lib/st-dump.pl';
}

use strict;
use vars qw($file_magic_str $other_magic $network_magic $major $minor
           $C_visible_byteorder);

BEGIN {
# Config.pm does games to figure out byteorder dynamically. In the process
# it creates an 8 digit entry on long long builds on 32 bit long systems.
# config.sh, config.h and therefore Storable.xs have a 4 digit entry.
$C_visible_byteorder = $Config{byteorder};
if ($^O ne 'MSWin32' and $Config{longsize} != $Config{ivsize}) {
  if ($C_visible_byteorder =~ /^1234/) {
    # Little endian
    substr ($C_visible_byteorder, $Config{longsize}) = '';
  } elsif ($C_visible_byteorder =~ /4321$/) {
    # Big endian
    $C_visible_byteorder = substr ($C_visible_byteorder, -$Config{longsize});
  } else {
    die "longs are $Config{longsize} bytes, IVs are $Config{ivsize}, byte order $C_visible_byteorder not regonised";
  }
}
}

# header size depends on the size of the byteorder string
$file_magic_str = 'pst0';
$other_magic = 7 + length($C_visible_byteorder);
$network_magic = 2;
$major = 2;
$minor = 5;

use Test;
BEGIN { plan tests => 334 + length($C_visible_byteorder) * 4}

use Storable qw (store retrieve freeze thaw nstore nfreeze);

my $file = "malice.$$";
die "Temporary file 'malice.$$' already exists" if -e $file;

END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}

my %hash = (perl => 'rules');

sub test_hash {
  my $clone = shift;
  ok (ref $clone, "HASH", "Get hash back");
  ok (scalar keys %$clone, 1, "with 1 key");
  ok ((keys %$clone)[0], "perl", "which is correct");
  ok ($clone->{perl}, "rules");
}

sub test_header {
  my ($header, $isfile, $isnetorder) = @_;
  ok (!!$header->{file}, !!$isfile, "is file");
  ok ($header->{major}, $major, "major number");
  ok ($header->{minor}, $minor, "minor number");
  ok (!!$header->{netorder}, !!$isnetorder, "is network order");
  if ($isnetorder) {
    # Skip these
    for (1..5) {
      ok (1, 1, "Network order header has no sizes");
    }
  } else {
    ok ($header->{byteorder}, $C_visible_byteorder, "byte order");
    ok ($header->{intsize}, $Config{intsize}, "int size");
    ok ($header->{longsize}, $Config{longsize}, "long size");
    ok ($header->{ptrsize}, $Config{ptrsize}, "long size");
    ok ($header->{nvsize}, $Config{nvsize} || $Config{doublesize} || 8,
        "nv size"); # 5.00405 doesn't even have doublesize in config.
  }
}

sub store_and_retrieve {
  my $data = shift;
  unlink $file or die "Can't unlink '$file': $!";
  open FH, ">$file" or die "Can't open '$file': $!";
  binmode FH;
  print FH $data or die "Can't print to '$file': $!";
  close FH or die "Can't close '$file': $!";

  return  eval {retrieve $file};
}

sub freeze_and_thaw {
  my $data = shift;
  return eval {thaw $data};
}

sub test_truncated {
  my ($data, $sub, $magic_len, $what) = @_;
  for my $i (0 .. length ($data) - 1) {
    my $short = substr $data, 0, $i;

    my $clone = &$sub($short);
    ok (defined ($clone), '', "truncated $what to $i should fail");
    if ($i < $magic_len) {
      ok ($@, "/^Magic number checking on storable $what failed/",
          "Should croak with magic number warning");
    } else {
      ok ($@, "", "Should not set \$\@");
    }
  }
}

sub test_corrupt {
  my ($data, $sub, $what, $name) = @_;

  my $clone = &$sub($data);
  ok (defined ($clone), '', "$name $what should fail");
  ok ($@, $what, $name);
}

sub test_things {
  my ($contents, $sub, $what, $isnetwork) = @_;
  my $isfile = $what eq 'file';
  my $file_magic = $isfile ? length $file_magic_str : 0;

  my $header = Storable::read_magic ($contents);
  test_header ($header, $isfile, $isnetwork);

  # Test that if we re-write it, everything still works:
  my $clone = &$sub ($contents);

  ok ($@, "", "There should be no error");

  test_hash ($clone);

  # Now lets check the short version:
  test_truncated ($contents, $sub, $file_magic
                  + ($isnetwork ? $network_magic : $other_magic), $what);

  my $copy;
  if ($isfile) {
    $copy = $contents;
    substr ($copy, 0, 4) = 'iron';
    test_corrupt ($copy, $sub, "/^File is not a perl storable/",
                  "magic number");
  }

  $copy = $contents;
  my $minor1 = $header->{minor} + 1;
  substr ($copy, $file_magic + 1, 1) = chr $minor1;
  test_corrupt ($copy, $sub,
                "/^Storable binary image v$header->{major}\.$minor1 more recent than I am \\(v$header->{major}\.$header->{minor}\\)/",
                "higher minor");

  $copy = $contents;
  my $major1 = $header->{major} + 1;
  substr ($copy, $file_magic, 1) = chr 2*$major1;
  test_corrupt ($copy, $sub,
                "/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$header->{minor}\\)/",
                "higher major");

  # Continue messing with the previous copy
  $minor1 = $header->{minor} - 1;
  substr ($copy, $file_magic + 1, 1) = chr $minor1;
  test_corrupt ($copy, $sub,
                "/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$header->{minor}\\)/",
              "higher major, lower minor");

  my $where;
  if (!$isnetwork) {
    # All these are omitted from the network order header.
    # I'm not sure if it's correct to omit the byte size stuff.
    $copy = $contents;
    substr ($copy, $file_magic + 3, length $header->{byteorder})
      = reverse $header->{byteorder};

    test_corrupt ($copy, $sub, "/^Byte order is not compatible/",
                  "byte order");
    $where = $file_magic + 3 + length $header->{byteorder};
    foreach (['intsize', "Integer"],
             ['longsize', "Long integer"],
             ['ptrsize', "Pointer integer"],
             ['nvsize', "Double"]) {
      my ($key, $name) = @$_;
      $copy = $contents;
      substr ($copy, $where++, 1) = chr 0;
      test_corrupt ($copy, $sub, "/^$name size is not compatible/",
                    "$name size");
    }
  } else {
    $where = $file_magic + $network_magic;
  }

  # Just the header and a tag 255. As 26 is currently the highest tag, this
  # is "unexpected"
  $copy = substr ($contents, 0, $where) . chr 255;

  test_corrupt ($copy, $sub,
                "/^Corrupted storable $what \\(binary v$header->{major}.$header->{minor}\\)/",
                "bogus tag");
}

sub slurp {
  my $file = shift;
  local (*FH, $/);
  open FH, "<$file" or die "Can't open '$file': $!";
  binmode FH;
  my $contents = <FH>;
  die "Can't read $file: $!" unless defined $contents;
  return $contents;
}


ok (defined store(\%hash, $file));

my $expected = 20 + length ($file_magic_str) + $other_magic;
my $length = -s $file;

die "Don't seem to have written file '$file' as I can't get its length: $!"
  unless defined $file;

die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
  unless $length == $expected;

# Read the contents into memory:
my $contents = slurp $file;

# Test the original direct from disk
my $clone = retrieve $file;
test_hash ($clone);

# Then test it.
test_things($contents, \&store_and_retrieve, 'file');

# And now try almost everything again with a Storable string
my $stored = freeze \%hash;
test_things($stored, \&freeze_and_thaw, 'string');

# Network order.
unlink $file or die "Can't unlink '$file': $!";

ok (defined nstore(\%hash, $file));

$expected = 20 + length ($file_magic_str) + $network_magic;
$length = -s $file;

die "Don't seem to have written file '$file' as I can't get its length: $!"
  unless defined $file;

die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
  unless $length == $expected;

# Read the contents into memory:
$contents = slurp $file;

# Test the original direct from disk
$clone = retrieve $file;
test_hash ($clone);

# Then test it.
test_things($contents, \&store_and_retrieve, 'file', 1);

# And now try almost everything again with a Storable string
$stored = nfreeze \%hash;
test_things($stored, \&freeze_and_thaw, 'string', 1);
Commit	Line	Data
b8778c7c	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;
291cf09c	33	use vars qw($file_magic_str $other_magic $network_magic $major $minor
291cf09c	34	$C_visible_byteorder);
291cf09c	35
96ef0061	36	BEGIN {
291cf09c	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};
96ef0061	41	if ($^O ne 'MSWin32' and $Config{longsize} != $Config{ivsize}) {
291cf09c	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	}
96ef0061	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;
b8778c7c	60
b8778c7c	61	use Test;
96ef0061	62	BEGIN { plan tests => 334 + length($C_visible_byteorder) * 4}
b8778c7c	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");
291cf09c	84	ok ($header->{major}, $major, "major number");
291cf09c	85	ok ($header->{minor}, $minor, "minor number");
b8778c7c	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 {
291cf09c	93	ok ($header->{byteorder}, $C_visible_byteorder, "byte order");
b8778c7c	94	ok ($header->{intsize}, $Config{intsize}, "int size");
b8778c7c	95	ok ($header->{longsize}, $Config{longsize}, "long size");
291cf09c	96	ok ($header->{ptrsize}, $Config{ptrsize}, "long size");
b8778c7c	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,
291cf09c	173	"/^Storable binary image v$header->{major}\.$minor1 more recent than I am \\(v$header->{major}\.$header->{minor}\\)/",
b8778c7c	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,
291cf09c	180	"/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$header->{minor}\\)/",
b8778c7c	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,
291cf09c	187	"/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$header->{minor}\\)/",
b8778c7c	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"],
291cf09c	202	['longsize', "Long integer"],
b8778c7c	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
291cf09c	243	die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
b8778c7c	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
291cf09c	271	die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
b8778c7c	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);