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