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