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 |
58 | -1, 0, 1, -127, -128, -129, 42, 126, 127, 128, 129, 254, 255, 256, 256, |
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 | |
70 | plan tests => @processes * @numbers * 4; |
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); |
128 | # use Devel::Peek; Dump $copy0; |
129 | if (is (ref $copy_s, "SCALAR", "got back a scalar ref?")) { |
130 | # Test inside use integer to see if the bit pattern is identical |
131 | # and outside to see if the sign is right. |
132 | # On 5.8 we don't need this trickery anymore. |
133 | my $eq = do {use integer; $$copy_s == $copy1} && $$copy_s == $copy1; |
134 | ok ($eq, "$process $copy1") or |
135 | printf "# Passed in $copy1, got back %s\n", |
136 | defined $$copy_s ? $$copy_s : undef; |
137 | } else { |
138 | fail ("$process $copy1"); |
139 | } |
140 | } |
141 | } |