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