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