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