10 use strict; use warnings;
14 use Hash::Util::FieldHash qw( :all);
15 my $ob_reg = Hash::Util::FieldHash::_ob_reg;
17 #########################
19 my $fieldhash_mode = 2;
21 # define ref types to use with some tests
24 # skipping CODE refs, they are differently scoped
25 @test_types = qw( SCALAR ARRAY HASH GLOB);
30 BEGIN { $n_tests += 4 }
32 is id( $ref), refaddr( $ref), "id is refaddr";
34 Hash::Util::FieldHash::_fieldhash \ %h, $fieldhash_mode;
37 is id( $ref), $key, "id is FieldHash key";
38 my $scalar = 'string';
39 is id( $scalar), $scalar, "string passes unchanged";
41 is id( $scalar), $scalar, "number passes unchanged";
44 ### idhash functionality
46 BEGIN { $n_tests += 3 }
47 Hash::Util::FieldHash::idhash my %h;
52 is $key, id( $ref), "idhash key correct";
53 is $h{ $ref}, $val, "value retrieved through ref";
54 is scalar keys %$ob_reg, 0, "no auto-registry in idhash";
57 ### the register() and id_2obj functions
59 BEGIN { $n_tests += 9 }
62 is id_2obj( $id), undef, "unregistered object not retrieved";
63 is scalar keys %$ob_reg, 0, "object registry empty";
64 is register( $obj), $obj, "object returned by register";
65 is scalar keys %$ob_reg, 1, "object registry nonempty";
66 is id_2obj( $id), $obj, "registered object retrieved";
68 register( $obj, \ %hash);
70 is scalar keys %hash, 1, "key present in registered hash";
72 is scalar keys %hash, 0, "key collected from registered hash";
73 is scalar keys %$ob_reg, 0, "object registry empty again";
74 eval { register( 1234) };
75 like $@, qr/^Attempt to register/, "registering non-ref is fatal";
79 ### Object auto-registry
81 BEGIN { $n_tests += 3 }
87 Hash::Util::FieldHash::_fieldhash $h, $fieldhash_mode;
89 is( keys %$ob_reg, 1, "one object registered");
91 # field hash stays alive until $obj dies
92 is( keys %$ob_reg, 1, "object still registered");
94 is( keys %$ob_reg, 0, "object unregistered");
97 ### existence/retrieval/deletion
98 BEGIN { $n_tests += 6 }
102 Hash::Util::FieldHash::_fieldhash \ my( %h), $fieldhash_mode;
103 for ( [ str => 'abc'], [ ref => {}] ) {
104 my ( $keytype, $key) = @$_;
106 ok( exists $h{ $key}, "existence ($keytype)");
107 is( $h{ $key}, $val, "retrieval ($keytype)");
109 is( keys %h, 0, "deletion ($keytype)");
113 ### id-action (stringification independent of bless)
114 BEGIN { $n_tests += 5 }
115 # use Scalar::Util qw( refaddr);
118 Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
119 Hash::Util::FieldHash::_fieldhash \ %g, $fieldhash_mode;
123 is( $f{ $key}, $val, "plain key set in field");
125 my $refaddr = hex +($key =~ /\(0x([[:xdigit:]]+)\)$/)[ 0];
126 is $id, $refaddr, "key is refaddr";
128 is( $f{ $key}, $val, "access through blessed");
131 is( $h{ $key}, $val, "plain key set in hash");
133 isnt( $h{ $key}, $val, "no access through blessed");
137 BEGIN { $n_tests += 1 + 2*( 3*@test_types + 5) + 1 + 2 }
141 Hash::Util::FieldHash::_fieldhash \ %h, $fieldhash_mode;
143 is( keys %h, 0, "blip");
146 for my $preload ( [], [ map {}, 1 .. 3] ) {
147 my $pre = @$preload ? ' (preloaded)' : '';
149 Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
150 my @preval = map "$_", @$preload;
151 @f{ @$preload} = @preval;
152 # Garbage collection separately
153 for my $type ( @test_types) {
155 my $ref = gen_ref( $type);
157 my ( $val) = grep $_ eq $type, values %f;
158 is( $val, $type, "$type visible$pre");
162 "$type obj registered$pre"
165 is( keys %f, @$preload, "$type gone$pre");
168 # Garbage collection collectively
169 is( keys %$ob_reg, @$preload, "no objs remaining$pre");
171 my @refs = map gen_ref( $_), @test_types;
172 @f{ @refs} = @test_types;
174 eq_set( [ values %f], [ @test_types, @preval]),
175 "all types present$pre",
179 @test_types + @$preload,
180 "all types registered$pre",
183 die "preload gone" unless defined $preload;
184 ok( eq_set( [ values %f], \ @preval), "all types gone$pre");
185 is( keys %$ob_reg, @$preload, "all types unregistered$pre");
187 is( keys %$ob_reg, 0, "preload gone after loop");
192 Hash::Util::FieldHash::_fieldhash \ %h, $fieldhash_mode;
194 my $x = $h{ $ref}->[ 0];
195 is keys %h, 1, "autovivified key present";
197 is keys %h, 0, "autovivified key collected";
201 BEGIN { $n_tests += 8 }
205 Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
207 my @refs = map [], 1 .. $size;
208 $f{ $_} = 1 for @refs;
209 is( keys %f, $size, "many keys singly");
213 "many objects singly",
216 is( keys %f, 0, "many keys singly gone");
220 "many objects singly unregistered",
224 my @refs = map [], 1 .. $size;
225 @f{ @refs } = ( 1) x @refs;
226 is( keys %f, $size, "many keys at once");
230 "many objects at once",
233 is( keys %f, 0, "many keys at once gone");
237 "many objects at once unregistered",
242 BEGIN { $n_tests += 6 }
245 my @fields = map {}, $n_fields;
246 Hash::Util::FieldHash::_fieldhash( $_, $fieldhash_mode) for @fields;
247 my @obs = map gen_ref( $_), @test_types;
249 for my $field ( @fields ) {
250 @{ $field }{ @obs} = map ref, @obs;
252 my $err = grep keys %$_ != @obs, @fields;
253 is( $err, 0, "$n_obs entries in $n_fields fields");
254 is( keys %$ob_reg, @obs, "$n_obs obs registered");
256 $err = grep keys %$_ != @obs, @fields;
257 is( $err, 0, "one entry gone from $n_fields fields");
258 is( keys %$ob_reg, @obs, "one ob unregistered");
260 $err = grep keys %$_ != @obs, @fields;
261 is( $err, 0, "all entries gone from $n_fields fields");
262 is( keys %$ob_reg, @obs, "all obs unregistered");
266 # direct hash assignment
267 BEGIN { $n_tests += 4 }
269 Hash::Util::FieldHash::_fieldhash( $_, $fieldhash_mode) for \ my( %f, %g, %h);
271 my @obs = map [], 1 .. $size;
272 @f{ @obs} = ( 1) x $size;
273 $g{ $_} = $f{ $_} for keys %f; # single assignment
274 %h = %f; # wholesale assignment
276 is keys %$ob_reg, 0, "all keys collected";
277 is keys %f, 0, "orig garbage-collected";
278 is keys %g, 0, "single-copy garbage-collected";
279 is keys %h, 0, "wholesale-copy garbage-collected";
283 BEGIN { $n_tests += 1 }
284 Hash::Util::FieldHash::_fieldhash \ my( %h), $fieldhash_mode;
285 bless \ %h, 'abc'; # this bus-errors with a certain bug
286 ok( 1, "no bus error on bless")
289 BEGIN { plan tests => $n_tests }
291 #######################################################################
295 hex +($ref =~ /\(0x([[:xdigit:]]+)\)$/)[ 0];
298 use Symbol qw( gensym);
302 SCALAR => sub { \ my $o },
305 GLOB => sub { gensym },
306 CODE => sub { sub {} },
309 sub gen_ref { $gen{ shift()}->() }