|
Packit |
14c646 |
#!./perl -w
|
|
Packit |
14c646 |
#
|
|
Packit |
14c646 |
# Copyright 2002, Larry Wall.
|
|
Packit |
14c646 |
#
|
|
Packit |
14c646 |
# You may redistribute only under the same terms as Perl 5, as specified
|
|
Packit |
14c646 |
# in the README file that comes with the distribution.
|
|
Packit |
14c646 |
#
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# I'm trying to keep this test easily backwards compatible to 5.004, so no
|
|
Packit |
14c646 |
# qr//;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# This test tries to craft malicious data to test out as many different
|
|
Packit |
14c646 |
# error traps in Storable as possible
|
|
Packit |
14c646 |
# It also acts as a test for read_header
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
sub BEGIN {
|
|
Packit |
14c646 |
# This lets us distribute Test::More in t/
|
|
Packit |
14c646 |
unshift @INC, 't';
|
|
Packit |
14c646 |
unshift @INC, 't/compat' if $] < 5.006002;
|
|
Packit |
14c646 |
require Config; import Config;
|
|
Packit |
14c646 |
if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
|
|
Packit |
14c646 |
print "1..0 # Skip: Storable was not built\n";
|
|
Packit |
14c646 |
exit 0;
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
use strict;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
our $byteorder = $Config{byteorder};
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
our $file_magic_str = 'pst0';
|
|
Packit |
14c646 |
our $other_magic = 7 + length $byteorder;
|
|
Packit |
14c646 |
our $network_magic = 2;
|
|
Packit |
14c646 |
our $major = 2;
|
|
Packit |
14c646 |
our $minor = 11;
|
|
Packit |
14c646 |
our $minor_write = $] >= 5.019 ? 11 : $] > 5.008 ? 9 : $] > 5.005_50 ? 8 : 4;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
use Test::More;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# If it's 5.7.3 or later the hash will be stored with flags, which is
|
|
Packit |
14c646 |
# 2 extra bytes. There are 2 * 2 * 2 tests per byte in the body and header
|
|
Packit |
14c646 |
# common to normal and network order serialised objects (hence the 8)
|
|
Packit |
14c646 |
# There are only 2 * 2 tests per byte in the parts of the header not present
|
|
Packit |
14c646 |
# for network order, and 2 tests per byte on the 'pst0' "magic number" only
|
|
Packit |
14c646 |
# present in files, but not in things store()ed to memory
|
|
Packit |
14c646 |
our $fancy = ($] > 5.007 ? 2 : 0);
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
plan tests => 372 + length ($byteorder) * 4 + $fancy * 8;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
use Storable qw (store retrieve freeze thaw nstore nfreeze);
|
|
Packit |
14c646 |
require 'testlib.pl';
|
|
Packit |
14c646 |
our $file;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# The chr 256 is a hack to force the hash to always have the utf8 keys flag
|
|
Packit |
14c646 |
# set on 5.7.3 and later. Otherwise the test fails if run with -Mutf8 because
|
|
Packit |
14c646 |
# only there does the hash has the flag on, and hence only there is it stored
|
|
Packit |
14c646 |
# as a flagged hash, which is 2 bytes longer
|
|
Packit |
14c646 |
my %hash = (perl => 'rules', chr 256, '');
|
|
Packit |
14c646 |
delete $hash{chr 256};
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
sub test_hash {
|
|
Packit |
14c646 |
my $clone = shift;
|
|
Packit |
14c646 |
is (ref $clone, "HASH", "Get hash back");
|
|
Packit |
14c646 |
is (scalar keys %$clone, 1, "with 1 key");
|
|
Packit |
14c646 |
is ((keys %$clone)[0], "perl", "which is correct");
|
|
Packit |
14c646 |
is ($clone->{perl}, "rules");
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
sub test_header {
|
|
Packit |
14c646 |
my ($header, $isfile, $isnetorder) = @_;
|
|
Packit |
14c646 |
is (!!$header->{file}, !!$isfile, "is file");
|
|
Packit |
14c646 |
is ($header->{major}, $major, "major number");
|
|
Packit |
14c646 |
is ($header->{minor}, $minor_write, "minor number");
|
|
Packit |
14c646 |
is (!!$header->{netorder}, !!$isnetorder, "is network order");
|
|
Packit |
14c646 |
if ($isnetorder) {
|
|
Packit |
14c646 |
# Network order header has no sizes
|
|
Packit |
14c646 |
} else {
|
|
Packit |
14c646 |
is ($header->{byteorder}, $byteorder, "byte order");
|
|
Packit |
14c646 |
is ($header->{intsize}, $Config{intsize}, "int size");
|
|
Packit |
14c646 |
is ($header->{longsize}, $Config{longsize}, "long size");
|
|
Packit |
14c646 |
SKIP: {
|
|
Packit |
14c646 |
skip ("No \$Config{prtsize} on this perl version ($])", 1)
|
|
Packit |
14c646 |
unless defined $Config{ptrsize};
|
|
Packit |
14c646 |
is ($header->{ptrsize}, $Config{ptrsize}, "long size");
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
is ($header->{nvsize}, $Config{nvsize} || $Config{doublesize} || 8,
|
|
Packit |
14c646 |
"nv size"); # 5.00405 doesn't even have doublesize in config.
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
sub test_truncated {
|
|
Packit |
14c646 |
my ($data, $sub, $magic_len, $what) = @_;
|
|
Packit |
14c646 |
for my $i (0 .. length ($data) - 1) {
|
|
Packit |
14c646 |
my $short = substr $data, 0, $i;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# local $Storable::DEBUGME = 1;
|
|
Packit |
14c646 |
my $clone = &$sub($short);
|
|
Packit |
14c646 |
is (defined ($clone), '', "truncated $what to $i should fail");
|
|
Packit |
14c646 |
if ($i < $magic_len) {
|
|
Packit |
14c646 |
like ($@, "/^Magic number checking on storable $what failed/",
|
|
Packit |
14c646 |
"Should croak with magic number warning");
|
|
Packit |
14c646 |
} else {
|
|
Packit |
14c646 |
is ($@, "", "Should not set \$\@");
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
sub test_corrupt {
|
|
Packit |
14c646 |
my ($data, $sub, $what, $name) = @_;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
my $clone = &$sub($data);
|
|
Packit |
14c646 |
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
|
Packit |
14c646 |
is (defined ($clone), '', "$name $what should fail");
|
|
Packit |
14c646 |
like ($@, $what, $name);
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
sub test_things {
|
|
Packit |
14c646 |
my ($contents, $sub, $what, $isnetwork) = @_;
|
|
Packit |
14c646 |
my $isfile = $what eq 'file';
|
|
Packit |
14c646 |
my $file_magic = $isfile ? length $file_magic_str : 0;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
my $header = Storable::read_magic ($contents);
|
|
Packit |
14c646 |
test_header ($header, $isfile, $isnetwork);
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Test that if we re-write it, everything still works:
|
|
Packit |
14c646 |
my $clone = &$sub ($contents);
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
is ($@, "", "There should be no error");
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
test_hash ($clone);
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Now lets check the short version:
|
|
Packit |
14c646 |
test_truncated ($contents, $sub, $file_magic
|
|
Packit |
14c646 |
+ ($isnetwork ? $network_magic : $other_magic), $what);
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
my $copy;
|
|
Packit |
14c646 |
if ($isfile) {
|
|
Packit |
14c646 |
$copy = $contents;
|
|
Packit |
14c646 |
substr ($copy, 0, 4) = 'iron';
|
|
Packit |
14c646 |
test_corrupt ($copy, $sub, "/^File is not a perl storable/",
|
|
Packit |
14c646 |
"magic number");
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
$copy = $contents;
|
|
Packit |
14c646 |
# Needs to be more than 1, as we're already coding a spread of 1 minor version
|
|
Packit |
14c646 |
# number on writes (2.5, 2.4). May increase to 2 if we figure we can do 2.3
|
|
Packit |
14c646 |
# on 5.005_03 (No utf8).
|
|
Packit |
14c646 |
# 4 allows for a small safety margin
|
|
Packit |
14c646 |
# Which we've now exhausted given that Storable 2.25 is writing 2.8
|
|
Packit |
14c646 |
# (Joke:
|
|
Packit |
14c646 |
# Question: What is the value of pi?
|
|
Packit |
14c646 |
# Mathematician answers "It's pi, isn't it"
|
|
Packit |
14c646 |
# Physicist answers "3.1, within experimental error"
|
|
Packit |
14c646 |
# Engineer answers "Well, allowing for a small safety margin, 18"
|
|
Packit |
14c646 |
# )
|
|
Packit |
14c646 |
my $minor6 = $header->{minor} + 6;
|
|
Packit |
14c646 |
substr ($copy, $file_magic + 1, 1) = chr $minor6;
|
|
Packit |
14c646 |
{
|
|
Packit |
14c646 |
# Now by default newer minor version numbers are not a pain.
|
|
Packit |
14c646 |
$clone = &$sub($copy);
|
|
Packit |
14c646 |
is ($@, "", "by default no error on higher minor");
|
|
Packit |
14c646 |
test_hash ($clone);
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
local $Storable::accept_future_minor = 0;
|
|
Packit |
14c646 |
test_corrupt ($copy, $sub,
|
|
Packit |
14c646 |
"/^Storable binary image v$header->{major}\.$minor6 more recent than I am \\(v$header->{major}\.$minor\\)/",
|
|
Packit |
14c646 |
"higher minor");
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
$copy = $contents;
|
|
Packit |
14c646 |
my $major1 = $header->{major} + 1;
|
|
Packit |
14c646 |
substr ($copy, $file_magic, 1) = chr 2*$major1;
|
|
Packit |
14c646 |
test_corrupt ($copy, $sub,
|
|
Packit |
14c646 |
"/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$minor\\)/",
|
|
Packit |
14c646 |
"higher major");
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Continue messing with the previous copy
|
|
Packit |
14c646 |
my $minor1 = $header->{minor} - 1;
|
|
Packit |
14c646 |
substr ($copy, $file_magic + 1, 1) = chr $minor1;
|
|
Packit |
14c646 |
test_corrupt ($copy, $sub,
|
|
Packit |
14c646 |
"/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$minor\\)/",
|
|
Packit |
14c646 |
"higher major, lower minor");
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
my $where;
|
|
Packit |
14c646 |
if (!$isnetwork) {
|
|
Packit |
14c646 |
# All these are omitted from the network order header.
|
|
Packit |
14c646 |
# I'm not sure if it's correct to omit the byte size stuff.
|
|
Packit |
14c646 |
$copy = $contents;
|
|
Packit |
14c646 |
substr ($copy, $file_magic + 3, length $header->{byteorder})
|
|
Packit |
14c646 |
= reverse $header->{byteorder};
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
test_corrupt ($copy, $sub, "/^Byte order is not compatible/",
|
|
Packit |
14c646 |
"byte order");
|
|
Packit |
14c646 |
$where = $file_magic + 3 + length $header->{byteorder};
|
|
Packit |
14c646 |
foreach (['intsize', "Integer"],
|
|
Packit |
14c646 |
['longsize', "Long integer"],
|
|
Packit |
14c646 |
['ptrsize', "Pointer"],
|
|
Packit |
14c646 |
['nvsize', "Double"]) {
|
|
Packit |
14c646 |
my ($key, $name) = @$_;
|
|
Packit |
14c646 |
$copy = $contents;
|
|
Packit |
14c646 |
substr ($copy, $where++, 1) = chr 0;
|
|
Packit |
14c646 |
test_corrupt ($copy, $sub, "/^$name size is not compatible/",
|
|
Packit |
14c646 |
"$name size");
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
} else {
|
|
Packit |
14c646 |
$where = $file_magic + $network_magic;
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Just the header and a tag 255. As 33 is currently the highest tag, this
|
|
Packit |
14c646 |
# is "unexpected"
|
|
Packit |
14c646 |
$copy = substr ($contents, 0, $where) . chr 255;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
test_corrupt ($copy, $sub,
|
|
Packit |
14c646 |
"/^Corrupted storable $what \\(binary v$header->{major}.$header->{minor}\\)/",
|
|
Packit |
14c646 |
"bogus tag");
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Now drop the minor version number
|
|
Packit |
14c646 |
substr ($copy, $file_magic + 1, 1) = chr $minor1;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
test_corrupt ($copy, $sub,
|
|
Packit |
14c646 |
"/^Corrupted storable $what \\(binary v$header->{major}.$minor1\\)/",
|
|
Packit |
14c646 |
"bogus tag, minor less 1");
|
|
Packit |
14c646 |
# Now increase the minor version number
|
|
Packit |
14c646 |
substr ($copy, $file_magic + 1, 1) = chr $minor6;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# local $Storable::DEBUGME = 1;
|
|
Packit |
14c646 |
# This is the delayed croak
|
|
Packit |
14c646 |
test_corrupt ($copy, $sub,
|
|
Packit |
14c646 |
"/^Storable binary image v$header->{major}.$minor6 contains data of type 255. This Storable is v$header->{major}.$minor and can only handle data types up to 33/",
|
|
Packit |
14c646 |
"bogus tag, minor plus 4");
|
|
Packit |
14c646 |
# And check again that this croak is not delayed:
|
|
Packit |
14c646 |
{
|
|
Packit |
14c646 |
# local $Storable::DEBUGME = 1;
|
|
Packit |
14c646 |
local $Storable::accept_future_minor = 0;
|
|
Packit |
14c646 |
test_corrupt ($copy, $sub,
|
|
Packit |
14c646 |
"/^Storable binary image v$header->{major}\.$minor6 more recent than I am \\(v$header->{major}\.$minor\\)/",
|
|
Packit |
14c646 |
"higher minor");
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
ok (defined store(\%hash, $file));
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
my $expected = 20 + length ($file_magic_str) + $other_magic + $fancy;
|
|
Packit |
14c646 |
my $length = -s $file;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
die "Don't seem to have written file '$file' as I can't get its length: $!"
|
|
Packit |
14c646 |
unless defined $file;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
|
|
Packit |
14c646 |
unless $length == $expected;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Read the contents into memory:
|
|
Packit |
14c646 |
my $contents = slurp ($file);
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Test the original direct from disk
|
|
Packit |
14c646 |
my $clone = retrieve $file;
|
|
Packit |
14c646 |
test_hash ($clone);
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Then test it.
|
|
Packit |
14c646 |
test_things($contents, \&store_and_retrieve, 'file');
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# And now try almost everything again with a Storable string
|
|
Packit |
14c646 |
my $stored = freeze \%hash;
|
|
Packit |
14c646 |
test_things($stored, \&freeze_and_thaw, 'string');
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Network order.
|
|
Packit |
14c646 |
unlink $file or die "Can't unlink '$file': $!";
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
ok (defined nstore(\%hash, $file));
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
$expected = 20 + length ($file_magic_str) + $network_magic + $fancy;
|
|
Packit |
14c646 |
$length = -s $file;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
die "Don't seem to have written file '$file' as I can't get its length: $!"
|
|
Packit |
14c646 |
unless defined $file;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length"
|
|
Packit |
14c646 |
unless $length == $expected;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Read the contents into memory:
|
|
Packit |
14c646 |
$contents = slurp ($file);
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Test the original direct from disk
|
|
Packit |
14c646 |
$clone = retrieve $file;
|
|
Packit |
14c646 |
test_hash ($clone);
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Then test it.
|
|
Packit |
14c646 |
test_things($contents, \&store_and_retrieve, 'file', 1);
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# And now try almost everything again with a Storable string
|
|
Packit |
14c646 |
$stored = nfreeze \%hash;
|
|
Packit |
14c646 |
test_things($stored, \&freeze_and_thaw, 'string', 1);
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Test that the bug fixed by #20587 doesn't affect us under some older
|
|
Packit |
14c646 |
# Perl. AMS 20030901
|
|
Packit |
14c646 |
{
|
|
Packit |
14c646 |
chop(my $a = chr(0xDF).chr(256));
|
|
Packit |
14c646 |
my %a = (chr(0xDF) => 1);
|
|
Packit |
14c646 |
$a{$a}++;
|
|
Packit |
14c646 |
freeze \%a;
|
|
Packit |
14c646 |
# If we were built with -DDEBUGGING, the assert() should have killed
|
|
Packit |
14c646 |
# us, which will probably alert the user that something went wrong.
|
|
Packit |
14c646 |
ok(1);
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Unusual in that the empty string is stored with an SX_LSCALAR marker
|
|
Packit |
14c646 |
my $hash = store_and_retrieve("pst0\5\6\3\0\0\0\1\1\0\0\0\0\0\0\0\5empty");
|
|
Packit |
14c646 |
ok(!$@, "no exception");
|
|
Packit |
14c646 |
is(ref($hash), "HASH", "got a hash");
|
|
Packit |
14c646 |
is($hash->{empty}, "", "got empty element");
|