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