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