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