[ID 20020609.007] Not OK: perl v5.8.0 +DEVEL17060 on i686-linux 2.4.18-4smp (UNINSTALLED)
[p5sagit/p5-mst-13.2.git] / ext / Storable / t / integer.t
CommitLineData
db670f21 1#!./perl -w
db670f21 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 ought to keep this test easily backwards compatible to 5.004, so no
10# qr//;
11
12# This test checks downgrade behaviour on pre-5.8 perls when new 5.8 features
13# are encountered.
14
15sub BEGIN {
16 if ($ENV{PERL_CORE}){
17 chdir('t') if -d 't';
18 @INC = ('.', '../lib');
19 } else {
20 unshift @INC, 't';
21 }
22 require Config; import Config;
23 if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
24 print "1..0 # Skip: Storable was not built\n";
25 exit 0;
26 }
27}
28
29use Test::More;
30use Storable qw (dclone store retrieve freeze thaw nstore nfreeze);
31use strict;
32
33my $max_uv = ~0;
34my $max_uv_m1 = ~0 ^ 1;
35# Express it in this way so as not to use any addition, as 5.6 maths would
36# do this in NVs on 64 bit machines, and we're overflowing IVs so can't use
37# use integer.
38my $max_iv_p1 = $max_uv ^ ($max_uv >> 1);
39my $lots_of_9C = do {
40 my $temp = sprintf "%X", ~0;
41 $temp =~ s/FF/9C/g;
42 local $^W;
43 hex $temp;
44};
45
46my $max_iv = ~0 >> 1;
47my $min_iv = do {use integer; -$max_iv-1}; # 2s complement assumption
48
49my @processes = (["dclone", \&do_clone],
50 ["freeze/thaw", \&freeze_and_thaw],
51 ["nfreeze/thaw", \&nfreeze_and_thaw],
52 ["store/retrieve", \&store_and_retrieve],
53 ["nstore/retrieve", \&store_and_retrieve],
54 );
55my @numbers =
56 (# IV bounds of 8 bits
f82cdaf6 57 -1, 0, 1, -127, -128, -129, 42, 126, 127, 128, 129, 254, 255, 256, 257,
db670f21 58 # IV bounds of 32 bits
59 -2147483647, -2147483648, -2147483649, 2147483646, 2147483647, 2147483648,
60 # IV bounds
61 $min_iv, do {use integer; $min_iv + 1}, do {use integer; $max_iv - 1},
62 $max_iv,
63 # UV bounds at 32 bits
64 0x7FFFFFFF, 0x80000000, 0x80000001, 0xFFFFFFFF, 0xDEADBEEF,
65 # UV bounds
66 $max_iv_p1, $max_uv_m1, $max_uv, $lots_of_9C,
67 );
68
f82cdaf6 69plan tests => @processes * @numbers * 5;
db670f21 70
71my $file = "integer.$$";
72die "Temporary file '$file' already exists" if -e $file;
73
74END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
75
76sub do_clone {
77 my $data = shift;
78 my $copy = eval {dclone $data};
79 is ($@, '', 'Should be no error dcloning');
80 ok (1, "dlcone is only 1 process, not 2");
81 return $copy;
82}
83
84sub freeze_and_thaw {
85 my $data = shift;
86 my $frozen = eval {freeze $data};
87 is ($@, '', 'Should be no error freezing');
88 my $copy = eval {thaw $frozen};
89 is ($@, '', 'Should be no error thawing');
90 return $copy;
91}
92
93sub nfreeze_and_thaw {
94 my $data = shift;
95 my $frozen = eval {nfreeze $data};
96 is ($@, '', 'Should be no error nfreezing');
97 my $copy = eval {thaw $frozen};
98 is ($@, '', 'Should be no error thawing');
99 return $copy;
100}
101
102sub store_and_retrieve {
103 my $data = shift;
104 my $frozen = eval {store $data, $file};
105 is ($@, '', 'Should be no error storing');
106 my $copy = eval {retrieve $file};
107 is ($@, '', 'Should be no error retrieving');
108 return $copy;
109}
110
111sub nstore_and_retrieve {
112 my $data = shift;
113 my $frozen = eval {nstore $data, $file};
114 is ($@, '', 'Should be no error storing');
115 my $copy = eval {retrieve $file};
116 is ($@, '', 'Should be no error retrieving');
117 return $copy;
118}
119
120foreach (@processes) {
121 my ($process, $sub) = @$_;
122 foreach my $number (@numbers) {
123 # as $number is an alias into @numbers, we don't want any side effects of
124 # conversion macros affecting later runs, so pass a copy to Storable:
125 my $copy1 = my $copy0 = $number;
126 my $copy_s = &$sub (\$copy0);
db670f21 127 if (is (ref $copy_s, "SCALAR", "got back a scalar ref?")) {
128 # Test inside use integer to see if the bit pattern is identical
129 # and outside to see if the sign is right.
130 # On 5.8 we don't need this trickery anymore.
f82cdaf6 131 # We really do need 2 copies here, as conversion may have side effect
132 # bugs. In particular, I know that this happens:
133 # perl5.00503 -le '$a = "-2147483649"; $a & 0; print $a; print $a+1'
134 # -2147483649
135 # 2147483648
136
137 my $copy_s1 = my $copy_s2 = $$copy_s;
138 # On 5.8 can do this with a straight ==, due to the integer/float maths
139 # on 5.6 can't do this with
140 # my $eq = do {use integer; $copy_s1 == $copy1} && $copy_s1 == $copy1;
141 # because on builds with IV as long long it tickles bugs.
142 # (Uncomment it and the Devel::Peek line below to see the messed up
143 # state of the scalar, with PV showing the correct string for the
144 # number, and IV holding a bogus value which has been truncated to 32 bits
145
146 # So, check the bit patterns are identical, and check that the sign is the
147 # same. This works on all the versions in all the sizes.
148 # $eq = && (($copy_s1 <=> 0) == ($copy1 <=> 0));
149 # Split this into 2 tests, to cater for 5.005_03
150
151 my $bit = ok (($copy_s1 ^ $copy1 == 0), "$process $copy1 (bitpattern)");
152 # This is sick. 5.005_03 survives without the IV/UV flag, and somehow
153 # gets it right, providing you don't have side effects of conversion.
154# local $TODO;
155# $TODO = "pre 5.6 doesn't have flag to distinguish IV/UV"
156# if $[ < 5.005_56 and $copy1 > $max_iv;
157 my $sign = ok (($copy_s2 <=> 0) == ($copy1 <=> 0),
158 "$process $copy1 (sign)");
159
160 unless ($bit and $sign) {
161 printf "# Passed in %s (%#x, %i)\n# got back '%s' (%#x, %i)\n",
162 $copy1, $copy1, $copy1, $copy_s1, $copy_s1, $copy_s1;
163 # use Devel::Peek; Dump $copy_s1; Dump $$copy_s;
164 }
165 # unless ($bit) { use Devel::Peek; Dump $copy_s1; Dump $$copy_s; }
db670f21 166 } else {
167 fail ("$process $copy1");
8ad6cd6e 168 fail ("$process $copy1");
db670f21 169 }
170 }
171}