Commit | Line | Data |
1e73acc8 |
1 | #!perl |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
6 | } |
7 | |
8 | use strict; use warnings; |
9 | use Test::More; |
10 | my $n_tests = 0; |
11 | |
12 | use Hash::Util::FieldHash qw( :all); |
13 | |
14 | ######################### |
15 | |
16 | # define ref types to use with some tests |
17 | my @test_types; |
18 | BEGIN { |
19 | # skipping CODE refs, they are differently scoped |
20 | @test_types = qw( SCALAR ARRAY HASH GLOB); |
21 | } |
22 | |
23 | ### Object registry |
24 | |
25 | BEGIN { $n_tests += 3 } |
26 | { |
27 | my $ob_reg = \ %Hash::Util::FieldHash::ob_reg; |
28 | { |
29 | my $obj = {}; |
30 | { |
31 | my $h; |
32 | fieldhash %$h; |
33 | $h->{ $obj} = 123; |
34 | is( keys %$ob_reg, 1, "one object registered"); |
35 | } |
36 | # field hash stays alive until $obj dies |
37 | is( keys %$ob_reg, 1, "object still registered"); |
38 | } |
39 | is( keys %$ob_reg, 0, "object unregistered"); |
40 | } |
41 | |
42 | ### existence/retrieval/deletion |
43 | BEGIN { $n_tests += 6 } |
44 | { |
45 | no warnings 'misc'; |
46 | my $val = 123; |
47 | fieldhash my %h; |
48 | for ( [ str => 'abc'], [ ref => {}] ) { |
49 | my ( $keytype, $key) = @$_; |
50 | $h{ $key} = $val; |
51 | ok( exists $h{ $key}, "existence ($keytype)"); |
52 | is( $h{ $key}, $val, "retrieval ($keytype)"); |
53 | delete $h{ $key}; |
54 | is( keys %h, 0, "deletion ($keytype)"); |
55 | } |
56 | } |
57 | |
58 | ### id-action (stringification independent of bless) |
59 | BEGIN { $n_tests += 4 } |
60 | { |
61 | my( %f, %g, %h, %i); |
62 | fieldhash %f; |
63 | fieldhash %g; |
64 | my $val = 123; |
65 | my $key = []; |
66 | $f{ $key} = $val; |
67 | is( $f{ $key}, $val, "plain key set in field"); |
68 | bless $key; |
69 | is( $f{ $key}, $val, "access through blessed"); |
70 | $key = []; |
71 | $h{ $key} = $val; |
72 | is( $h{ $key}, $val, "plain key set in hash"); |
73 | bless $key; |
74 | isnt( $h{ $key}, $val, "no access through blessed"); |
75 | } |
76 | |
77 | # Garbage collection |
78 | BEGIN { $n_tests += 1 + 2*( 3*@test_types + 5) + 1 } |
79 | |
80 | { |
81 | fieldhash my %h; |
82 | $h{ []} = 123; |
83 | is( keys %h, 0, "blip"); |
84 | } |
85 | |
86 | for my $preload ( [], [ map {}, 1 .. 3] ) { |
87 | my $pre = @$preload ? ' (preloaded)' : ''; |
88 | fieldhash my %f; |
89 | my @preval = map "$_", @$preload; |
90 | @f{ @$preload} = @preval; |
91 | # Garbage collection separately |
92 | for my $type ( @test_types) { |
93 | { |
94 | my $ref = gen_ref( $type); |
95 | $f{ $ref} = $type; |
96 | my ( $val) = grep $_ eq $type, values %f; |
97 | is( $val, $type, "$type visible$pre"); |
98 | is( |
99 | keys %Hash::Util::FieldHash::ob_reg, |
100 | 1 + @$preload, |
101 | "$type obj registered$pre" |
102 | ); |
103 | } |
104 | is( keys %f, @$preload, "$type gone$pre"); |
105 | } |
106 | |
107 | # Garbage collection collectively |
108 | is( keys %Hash::Util::FieldHash::ob_reg, @$preload, "no objs remaining$pre"); |
109 | { |
110 | my @refs = map gen_ref( $_), @test_types; |
111 | @f{ @refs} = @test_types; |
112 | ok( |
113 | eq_set( [ values %f], [ @test_types, @preval]), |
114 | "all types present$pre", |
115 | ); |
116 | is( |
117 | keys %Hash::Util::FieldHash::ob_reg, |
118 | @test_types + @$preload, |
119 | "all types registered$pre", |
120 | ); |
121 | } |
122 | die "preload gone" unless defined $preload; |
123 | ok( eq_set( [ values %f], \ @preval), "all types gone$pre"); |
124 | is( keys %Hash::Util::FieldHash::ob_reg, @$preload, "all types unregistered$pre"); |
125 | } |
126 | is( keys %Hash::Util::FieldHash::ob_reg, 0, "preload gone after loop"); |
127 | |
128 | # big key sets |
129 | BEGIN { $n_tests += 8 } |
130 | { |
131 | my $size = 10_000; |
132 | fieldhash( my %f); |
133 | { |
134 | my @refs = map [], 1 .. $size; |
135 | $f{ $_} = 1 for @refs; |
136 | is( keys %f, $size, "many keys singly"); |
137 | is( |
138 | keys %Hash::Util::FieldHash::ob_reg, |
139 | $size, |
140 | "many objects singly", |
141 | ); |
142 | } |
143 | is( keys %f, 0, "many keys singly gone"); |
144 | is( |
145 | keys %Hash::Util::FieldHash::ob_reg, |
146 | 0, |
147 | "many objects singly unregistered", |
148 | ); |
149 | |
150 | { |
151 | my @refs = map [], 1 .. $size; |
152 | $f{ $_} = 1 for @refs; |
153 | is( keys %f, $size, "many keys at once"); |
154 | is( |
155 | keys %Hash::Util::FieldHash::ob_reg, |
156 | $size, |
157 | "many objects at once", |
158 | ); |
159 | } |
160 | is( keys %f, 0, "many keys at once gone"); |
161 | is( |
162 | keys %Hash::Util::FieldHash::ob_reg, |
163 | 0, |
164 | "many objects at once unregistered", |
165 | ); |
166 | } |
167 | |
168 | # many field hashes |
169 | BEGIN { $n_tests += 6 } |
170 | { |
171 | my $n_fields = 1000; |
172 | my @fields = map &fieldhash( {}), 1 .. $n_fields; |
173 | my @obs = map gen_ref( $_), @test_types; |
174 | my $n_obs = @obs; |
175 | for my $field ( @fields ) { |
176 | @{ $field }{ @obs} = map ref, @obs; |
177 | } |
178 | my $err = grep keys %$_ != @obs, @fields; |
179 | is( $err, 0, "$n_obs entries in $n_fields fields"); |
180 | is( keys %Hash::Util::FieldHash::ob_reg, @obs, "$n_obs obs registered"); |
181 | pop @obs; |
182 | $err = grep keys %$_ != @obs, @fields; |
183 | is( $err, 0, "one entry gone from $n_fields fields"); |
184 | is( keys %Hash::Util::FieldHash::ob_reg, @obs, "one ob unregistered"); |
185 | @obs = (); |
186 | $err = grep keys %$_ != @obs, @fields; |
187 | is( $err, 0, "all entries gone from $n_fields fields"); |
188 | is( keys %Hash::Util::FieldHash::ob_reg, @obs, "all obs unregistered"); |
189 | } |
190 | |
191 | { |
192 | |
193 | BEGIN { $n_tests += 1 } |
194 | fieldhash my %h; |
195 | bless \ %h, 'abc'; # this bus-errors with a certain bug |
196 | ok( 1, "no bus error on bless") |
197 | } |
198 | |
199 | BEGIN { plan tests => $n_tests } |
200 | |
201 | ####################################################################### |
202 | |
203 | use Symbol qw( gensym); |
204 | |
205 | BEGIN { |
206 | my %gen = ( |
207 | SCALAR => sub { \ my $x }, |
208 | ARRAY => sub { [] }, |
209 | HASH => sub { {} }, |
210 | GLOB => sub { gensym }, |
211 | CODE => sub { sub {} }, |
212 | ); |
213 | |
214 | sub gen_ref { $gen{ shift()}->() } |
215 | } |