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
15sub BEGIN {
16    unshift @INC, 't';
17    unshift @INC, 't/compat' if $] < 5.006002;
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
25use Test::More;
26use Storable qw (dclone store retrieve freeze thaw nstore nfreeze);
27use strict;
28
29my $max_uv = ~0;
30my $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.
34my $max_iv_p1 = $max_uv ^ ($max_uv >> 1);
35my $lots_of_9C = do {
36  my $temp = sprintf "%#x", ~0;
37  $temp =~ s/ff/9c/g;
38  local $^W;
39  eval $temp;
40};
41
42my $max_iv = ~0 >> 1;
43my $min_iv = do {use integer; -$max_iv-1}; # 2s complement assumption
44
45my @processes = (["dclone", \&do_clone],
46                 ["freeze/thaw", \&freeze_and_thaw],
47                 ["nfreeze/thaw", \&nfreeze_and_thaw],
48                 ["store/retrieve", \&store_and_retrieve],
49                 ["nstore/retrieve", \&nstore_and_retrieve],
50                );
51my @numbers =
52  (# IV bounds of 8 bits
53   -1, 0, 1, -127, -128, -129, 42, 126, 127, 128, 129, 254, 255, 256, 257,
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,
63   # NV-UV conversion
64   2559831922.0,
65  );
66
67plan tests => @processes * @numbers * 5;
68
69my $file = "integer.$$";
70die "Temporary file '$file' already exists" if -e $file;
71
72END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
73
74sub 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
82sub 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
91sub 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
100sub 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
109sub 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
118foreach (@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:
123    my $copy1 = my $copy2 = my $copy0 = $number;
124    my $copy_s = &$sub (\$copy0);
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.
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
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)");
159      my $sign = ok (($copy_s2 <=> 0) == ($copy2 <=> 0),
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;
165        # use Devel::Peek; Dump $number; Dump $copy1; Dump $copy_s1;
166      }
167      # unless ($bit) { use Devel::Peek; Dump $copy_s1; Dump $$copy_s; }
168    } else {
169      fail ("$process $copy1");
170      fail ("$process $copy1");
171    }
172  }
173}
174