|
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 ought to keep this test easily backwards compatible to 5.004, so no
|
|
Packit |
14c646 |
# qr//;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# This test checks downgrade behaviour on pre-5.8 perls when new 5.8 features
|
|
Packit |
14c646 |
# are encountered.
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
sub BEGIN {
|
|
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 Test::More;
|
|
Packit |
14c646 |
use Storable qw (dclone store retrieve freeze thaw nstore nfreeze);
|
|
Packit |
14c646 |
use strict;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
my $max_uv = ~0;
|
|
Packit |
14c646 |
my $max_uv_m1 = ~0 ^ 1;
|
|
Packit |
14c646 |
# Express it in this way so as not to use any addition, as 5.6 maths would
|
|
Packit |
14c646 |
# do this in NVs on 64 bit machines, and we're overflowing IVs so can't use
|
|
Packit |
14c646 |
# use integer.
|
|
Packit |
14c646 |
my $max_iv_p1 = $max_uv ^ ($max_uv >> 1);
|
|
Packit |
14c646 |
my $lots_of_9C = do {
|
|
Packit |
14c646 |
my $temp = sprintf "%#x", ~0;
|
|
Packit |
14c646 |
$temp =~ s/ff/9c/g;
|
|
Packit |
14c646 |
local $^W;
|
|
Packit |
14c646 |
eval $temp;
|
|
Packit |
14c646 |
};
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
my $max_iv = ~0 >> 1;
|
|
Packit |
14c646 |
my $min_iv = do {use integer; -$max_iv-1}; # 2s complement assumption
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
my @processes = (["dclone", \&do_clone],
|
|
Packit |
14c646 |
["freeze/thaw", \&freeze_and_thaw],
|
|
Packit |
14c646 |
["nfreeze/thaw", \&nfreeze_and_thaw],
|
|
Packit |
14c646 |
["store/retrieve", \&store_and_retrieve],
|
|
Packit |
14c646 |
["nstore/retrieve", \&nstore_and_retrieve],
|
|
Packit |
14c646 |
);
|
|
Packit |
14c646 |
my @numbers =
|
|
Packit |
14c646 |
(# IV bounds of 8 bits
|
|
Packit |
14c646 |
-1, 0, 1, -127, -128, -129, 42, 126, 127, 128, 129, 254, 255, 256, 257,
|
|
Packit |
14c646 |
# IV bounds of 32 bits
|
|
Packit |
14c646 |
-2147483647, -2147483648, -2147483649, 2147483646, 2147483647, 2147483648,
|
|
Packit |
14c646 |
# IV bounds
|
|
Packit |
14c646 |
$min_iv, do {use integer; $min_iv + 1}, do {use integer; $max_iv - 1},
|
|
Packit |
14c646 |
$max_iv,
|
|
Packit |
14c646 |
# UV bounds at 32 bits
|
|
Packit |
14c646 |
0x7FFFFFFF, 0x80000000, 0x80000001, 0xFFFFFFFF, 0xDEADBEEF,
|
|
Packit |
14c646 |
# UV bounds
|
|
Packit |
14c646 |
$max_iv_p1, $max_uv_m1, $max_uv, $lots_of_9C,
|
|
Packit |
14c646 |
# NV-UV conversion
|
|
Packit |
14c646 |
2559831922.0,
|
|
Packit |
14c646 |
);
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
plan tests => @processes * @numbers * 5;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
my $file = "integer.$$";
|
|
Packit |
14c646 |
die "Temporary file '$file' already exists" if -e $file;
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
sub do_clone {
|
|
Packit |
14c646 |
my $data = shift;
|
|
Packit |
14c646 |
my $copy = eval {dclone $data};
|
|
Packit |
14c646 |
is ($@, '', 'Should be no error dcloning');
|
|
Packit |
14c646 |
ok (1, "dlcone is only 1 process, not 2");
|
|
Packit |
14c646 |
return $copy;
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
sub freeze_and_thaw {
|
|
Packit |
14c646 |
my $data = shift;
|
|
Packit |
14c646 |
my $frozen = eval {freeze $data};
|
|
Packit |
14c646 |
is ($@, '', 'Should be no error freezing');
|
|
Packit |
14c646 |
my $copy = eval {thaw $frozen};
|
|
Packit |
14c646 |
is ($@, '', 'Should be no error thawing');
|
|
Packit |
14c646 |
return $copy;
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
sub nfreeze_and_thaw {
|
|
Packit |
14c646 |
my $data = shift;
|
|
Packit |
14c646 |
my $frozen = eval {nfreeze $data};
|
|
Packit |
14c646 |
is ($@, '', 'Should be no error nfreezing');
|
|
Packit |
14c646 |
my $copy = eval {thaw $frozen};
|
|
Packit |
14c646 |
is ($@, '', 'Should be no error thawing');
|
|
Packit |
14c646 |
return $copy;
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
sub store_and_retrieve {
|
|
Packit |
14c646 |
my $data = shift;
|
|
Packit |
14c646 |
my $frozen = eval {store $data, $file};
|
|
Packit |
14c646 |
is ($@, '', 'Should be no error storing');
|
|
Packit |
14c646 |
my $copy = eval {retrieve $file};
|
|
Packit |
14c646 |
is ($@, '', 'Should be no error retrieving');
|
|
Packit |
14c646 |
return $copy;
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
sub nstore_and_retrieve {
|
|
Packit |
14c646 |
my $data = shift;
|
|
Packit |
14c646 |
my $frozen = eval {nstore $data, $file};
|
|
Packit |
14c646 |
is ($@, '', 'Should be no error storing');
|
|
Packit |
14c646 |
my $copy = eval {retrieve $file};
|
|
Packit |
14c646 |
is ($@, '', 'Should be no error retrieving');
|
|
Packit |
14c646 |
return $copy;
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
foreach (@processes) {
|
|
Packit |
14c646 |
my ($process, $sub) = @$_;
|
|
Packit |
14c646 |
foreach my $number (@numbers) {
|
|
Packit |
14c646 |
# as $number is an alias into @numbers, we don't want any side effects of
|
|
Packit |
14c646 |
# conversion macros affecting later runs, so pass a copy to Storable:
|
|
Packit |
14c646 |
my $copy1 = my $copy2 = my $copy0 = $number;
|
|
Packit |
14c646 |
my $copy_s = &$sub (\$copy0);
|
|
Packit |
14c646 |
if (is (ref $copy_s, "SCALAR", "got back a scalar ref?")) {
|
|
Packit |
14c646 |
# Test inside use integer to see if the bit pattern is identical
|
|
Packit |
14c646 |
# and outside to see if the sign is right.
|
|
Packit |
14c646 |
# On 5.8 we don't need this trickery anymore.
|
|
Packit |
14c646 |
# We really do need 2 copies here, as conversion may have side effect
|
|
Packit |
14c646 |
# bugs. In particular, I know that this happens:
|
|
Packit |
14c646 |
# perl5.00503 -le '$a = "-2147483649"; $a & 0; print $a; print $a+1'
|
|
Packit |
14c646 |
# -2147483649
|
|
Packit |
14c646 |
# 2147483648
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
my $copy_s1 = my $copy_s2 = $$copy_s;
|
|
Packit |
14c646 |
# On 5.8 can do this with a straight ==, due to the integer/float maths
|
|
Packit |
14c646 |
# on 5.6 can't do this with
|
|
Packit |
14c646 |
# my $eq = do {use integer; $copy_s1 == $copy1} && $copy_s1 == $copy1;
|
|
Packit |
14c646 |
# because on builds with IV as long long it tickles bugs.
|
|
Packit |
14c646 |
# (Uncomment it and the Devel::Peek line below to see the messed up
|
|
Packit |
14c646 |
# state of the scalar, with PV showing the correct string for the
|
|
Packit |
14c646 |
# number, and IV holding a bogus value which has been truncated to 32 bits
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# So, check the bit patterns are identical, and check that the sign is the
|
|
Packit |
14c646 |
# same. This works on all the versions in all the sizes.
|
|
Packit |
14c646 |
# $eq = && (($copy_s1 <=> 0) == ($copy1 <=> 0));
|
|
Packit |
14c646 |
# Split this into 2 tests, to cater for 5.005_03
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Aargh. Even this doesn't work because 5.6.x sends values with (same
|
|
Packit |
14c646 |
# number of decimal digits as ~0 + 1) via atof. So ^ is getting strings
|
|
Packit |
14c646 |
# cast to doubles cast to integers. And that truncates low order bits.
|
|
Packit |
14c646 |
# my $bit = ok (($copy_s1 ^ $copy1) == 0, "$process $copy1 (bitpattern)");
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
# Oh well; at least the parser gets it right. :-)
|
|
Packit |
14c646 |
my $copy_s3 = eval $copy_s1;
|
|
Packit |
14c646 |
die "Was supposed to have number $copy_s3, got error $@"
|
|
Packit |
14c646 |
unless defined $copy_s3;
|
|
Packit |
14c646 |
my $bit = ok (($copy_s3 ^ $copy1) == 0, "$process $copy1 (bitpattern)");
|
|
Packit |
14c646 |
# This is sick. 5.005_03 survives without the IV/UV flag, and somehow
|
|
Packit |
14c646 |
# gets it right, providing you don't have side effects of conversion.
|
|
Packit |
14c646 |
# local $TODO;
|
|
Packit |
14c646 |
# $TODO = "pre 5.6 doesn't have flag to distinguish IV/UV"
|
|
Packit |
14c646 |
# if $] < 5.005_56 and $copy1 > $max_iv;
|
|
Packit |
14c646 |
my $sign = ok (($copy_s2 <=> 0) == ($copy2 <=> 0),
|
|
Packit |
14c646 |
"$process $copy1 (sign)");
|
|
Packit |
14c646 |
|
|
Packit |
14c646 |
unless ($bit and $sign) {
|
|
Packit |
14c646 |
printf "# Passed in %s (%#x, %i)\n# got back '%s' (%#x, %i)\n",
|
|
Packit |
14c646 |
$copy1, $copy1, $copy1, $copy_s1, $copy_s1, $copy_s1;
|
|
Packit |
14c646 |
# use Devel::Peek; Dump $number; Dump $copy1; Dump $copy_s1;
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
# unless ($bit) { use Devel::Peek; Dump $copy_s1; Dump $$copy_s; }
|
|
Packit |
14c646 |
} else {
|
|
Packit |
14c646 |
fail ("$process $copy1");
|
|
Packit |
14c646 |
fail ("$process $copy1");
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
}
|
|
Packit |
14c646 |
}
|