ext/Storable/t/canonical.t

   1 #!./perl
   2 #
   3 #  Copyright (c) 1995-2000, Raphael Manfredi
   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 sub BEGIN {
  10     if ($ENV{PERL_CORE}){
  11         chdir('t') if -d 't';
  12         @INC = ('.', '../lib');
  13     } else {
  14         unshift @INC, 't';
  15     }
  16     require Config; import Config;
  17     if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
  18         print "1..0 # Skip: Storable was not built\n";
  19         exit 0;
  20     }
  21 }
  22
  23
  24 use Storable qw(freeze thaw dclone);
  25 use vars qw($debugging $verbose);
  26
  27 print "1..8\n";
  28
  29 sub ok {
  30     my($testno, $ok) = @_;
  31     print "not " unless $ok;
  32     print "ok $testno\n";
  33 }
  34
  35
  36 # Uncomment the folowing line to get a dump of the constructed data structure
  37 # (you may want to reduce the size of the hashes too)
  38 # $debugging = 1;
  39
  40 $hashsize = 100;
  41 $maxhash2size = 100;
  42 $maxarraysize = 100;
  43
  44 # Use MD5 if its available to make random string keys
  45
  46 eval { require "MD5.pm" };
  47 $gotmd5 = !$@;
  48
  49 # Use Data::Dumper if debugging and it is available to create an ASCII dump
  50
  51 if ($debugging) {
  52     eval { require "Data/Dumper.pm" };
  53     $gotdd  = !$@;
  54 }
  55
  56 @fixed_strings = ("January", "February", "March", "April", "May", "June",
  57                   "July", "August", "September", "October", "November", "December" );
  58
  59 # Build some arbitrarily complex data structure starting with a top level hash
  60 # (deeper levels contain scalars, references to hashes or references to arrays);
  61
  62 for (my $i = 0; $i < $hashsize; $i++) {
  63         my($k) = int(rand(1_000_000));
  64         $k = MD5->hexhash($k) if $gotmd5 and int(rand(2));
  65         $a1{$k} = { key => "$k", "value" => $i };
  66
  67         # A third of the elements are references to further hashes
  68
  69         if (int(rand(1.5))) {
  70                 my($hash2) = {};
  71                 my($hash2size) = int(rand($maxhash2size));
  72                 while ($hash2size--) {
  73                         my($k2) = $k . $i . int(rand(100));
  74                         $hash2->{$k2} = $fixed_strings[rand(int(@fixed_strings))];
  75                 }
  76                 $a1{$k}->{value} = $hash2;
  77         }
  78
  79         # A further third are references to arrays
  80
  81         elsif (int(rand(2))) {
  82                 my($arr_ref) = [];
  83                 my($arraysize) = int(rand($maxarraysize));
  84                 while ($arraysize--) {
  85                         push(@$arr_ref, $fixed_strings[rand(int(@fixed_strings))]);
  86                 }
  87                 $a1{$k}->{value} = $arr_ref;
  88         }
  89 }
  90
  91
  92 print STDERR Data::Dumper::Dumper(\%a1) if ($verbose and $gotdd);
  93
  94
  95 # Copy the hash, element by element in order of the keys
  96
  97 foreach $k (sort keys %a1) {
  98     $a2{$k} = { key => "$k", "value" => $a1{$k}->{value} };
  99 }
 100
 101 # Deep clone the hash
 102
 103 $a3 = dclone(\%a1);
 104
 105 # In canonical mode the frozen representation of each of the hashes
 106 # should be identical
 107
 108 $Storable::canonical = 1;
 109
 110 $x1 = freeze(\%a1);
 111 $x2 = freeze(\%a2);
 112 $x3 = freeze($a3);
 113
 114 ok 1, (length($x1) > $hashsize);        # sanity check
 115 ok 2, length($x1) == length($x2);       # idem
 116 ok 3, $x1 eq $x2;
 117 ok 4, $x1 eq $x3;
 118
 119 # In normal mode it is exceedingly unlikely that the frozen
 120 # representaions of all the hashes will be the same (normally the hash
 121 # elements are frozen in the order they are stored internally,
 122 # i.e. pseudo-randomly).
 123
 124 $Storable::canonical = 0;
 125
 126 $x1 = freeze(\%a1);
 127 $x2 = freeze(\%a2);
 128 $x3 = freeze($a3);
 129
 130
 131 # Two out of three the same may be a coincidence, all three the same
 132 # is much, much more unlikely.  Still it could happen, so this test
 133 # may report a false negative.
 134
 135 ok 5, ($x1 ne $x2) || ($x1 ne $x3);
 136
 137
 138 # Ensure refs to "undef" values are properly shared
 139 # Same test as in t/dclone.t to ensure the "canonical" code is also correct
 140
 141 my $hash;
 142 push @{$$hash{''}}, \$$hash{a};
 143 ok 6, $$hash{''}[0] == \$$hash{a};
 144
 145 my $cloned = dclone(dclone($hash));
 146 ok 7, $$cloned{''}[0] == \$$cloned{a};
 147
 148 $$cloned{a} = "blah";
 149 ok 8, $$cloned{''}[0] == \$$cloned{a};