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