ext/Storable/t/canonical.t

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