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 { |
16 | chdir('t') if -d 't'; |
20822f61 |
17 | @INC = '.'; |
18 | push @INC, '../lib'; |
9f233367 |
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 | } |
7a6a85bf |
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 | |