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