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