10 use strict; use warnings;
14 use Hash::Util::FieldHash qw( :all);
15 my $ob_reg = Hash::Util::FieldHash::_ob_reg;
17 #########################
19 # define ref types to use with some tests
22 # skipping CODE refs, they are differently scoped
23 @test_types = qw( SCALAR ARRAY HASH GLOB);
28 BEGIN { $n_tests += 3 }
36 is( keys %$ob_reg, 1, "one object registered");
38 # field hash stays alive until $obj dies
39 is( keys %$ob_reg, 1, "object still registered");
41 is( keys %$ob_reg, 0, "object unregistered");
44 ### existence/retrieval/deletion
45 BEGIN { $n_tests += 6 }
50 for ( [ str => 'abc'], [ ref => {}] ) {
51 my ( $keytype, $key) = @$_;
53 ok( exists $h{ $key}, "existence ($keytype)");
54 is( $h{ $key}, $val, "retrieval ($keytype)");
56 is( keys %h, 0, "deletion ($keytype)");
60 ### id-action (stringification independent of bless)
61 BEGIN { $n_tests += 4 }
69 is( $f{ $key}, $val, "plain key set in field");
71 is( $f{ $key}, $val, "access through blessed");
74 is( $h{ $key}, $val, "plain key set in hash");
76 isnt( $h{ $key}, $val, "no access through blessed");
80 BEGIN { $n_tests += 1 + 2*( 3*@test_types + 5) + 1 }
85 is( keys %h, 0, "blip");
88 for my $preload ( [], [ map {}, 1 .. 3] ) {
89 my $pre = @$preload ? ' (preloaded)' : '';
91 my @preval = map "$_", @$preload;
92 @f{ @$preload} = @preval;
93 # Garbage collection separately
94 for my $type ( @test_types) {
96 my $ref = gen_ref( $type);
98 my ( $val) = grep $_ eq $type, values %f;
99 is( $val, $type, "$type visible$pre");
103 "$type obj registered$pre"
106 is( keys %f, @$preload, "$type gone$pre");
109 # Garbage collection collectively
110 is( keys %$ob_reg, @$preload, "no objs remaining$pre");
112 my @refs = map gen_ref( $_), @test_types;
113 @f{ @refs} = @test_types;
115 eq_set( [ values %f], [ @test_types, @preval]),
116 "all types present$pre",
120 @test_types + @$preload,
121 "all types registered$pre",
124 die "preload gone" unless defined $preload;
125 ok( eq_set( [ values %f], \ @preval), "all types gone$pre");
126 is( keys %$ob_reg, @$preload, "all types unregistered$pre");
128 is( keys %$ob_reg, 0, "preload gone after loop");
131 BEGIN { $n_tests += 8 }
136 my @refs = map [], 1 .. $size;
137 $f{ $_} = 1 for @refs;
138 is( keys %f, $size, "many keys singly");
142 "many objects singly",
145 is( keys %f, 0, "many keys singly gone");
149 "many objects singly unregistered",
153 my @refs = map [], 1 .. $size;
154 @f{ @refs } = ( 1) x @refs;
155 is( keys %f, $size, "many keys at once");
159 "many objects at once",
162 is( keys %f, 0, "many keys at once gone");
166 "many objects at once unregistered",
171 BEGIN { $n_tests += 6 }
174 my @fields = map &fieldhash( {}), 1 .. $n_fields;
175 my @obs = map gen_ref( $_), @test_types;
177 for my $field ( @fields ) {
178 @{ $field }{ @obs} = map ref, @obs;
180 my $err = grep keys %$_ != @obs, @fields;
181 is( $err, 0, "$n_obs entries in $n_fields fields");
182 is( keys %$ob_reg, @obs, "$n_obs obs registered");
184 $err = grep keys %$_ != @obs, @fields;
185 is( $err, 0, "one entry gone from $n_fields fields");
186 is( keys %$ob_reg, @obs, "one ob unregistered");
188 $err = grep keys %$_ != @obs, @fields;
189 is( $err, 0, "all entries gone from $n_fields fields");
190 is( keys %$ob_reg, @obs, "all obs unregistered");
194 # direct hash assignment
195 BEGIN { $n_tests += 4 }
197 fieldhashes \ my( %f, %g, %h);
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
204 is keys %$ob_reg, 0, "all keys collected";
205 is keys %f, 0, "orig garbage-collected";
206 is keys %g, 0, "single-copy garbage-dollected";
207 is keys %h, 0, "wholesale-copy garbage-dollected";
212 BEGIN { $n_tests += 1 }
214 bless \ %h, 'abc'; # this bus-errors with a certain bug
215 ok( 1, "no bus error on bless")
218 BEGIN { plan tests => $n_tests }
220 #######################################################################
222 use Symbol qw( gensym);
226 SCALAR => sub { \ my $x },
229 GLOB => sub { gensym },
230 CODE => sub { sub {} },
233 sub gen_ref { $gen{ shift()}->() }