ext/Storable/t/integer.t

   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, 257,
  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 * 5;
  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     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.
 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; }
 167     } else {
 168       fail ("$process $copy1");
 169       fail ("$process $copy1");
 170     }
 171   }
 172 }