1use strict;
2use warnings;
3no warnings 'experimental::builtin';
4use builtin qw(refaddr);
5
6use Test::More;
7use Hash::Util::FieldHash qw( :all);
8my $ob_reg = Hash::Util::FieldHash::_ob_reg;
9
10#########################
11
12my $fieldhash_mode = 2;
13
14# define ref types to use with some tests
15# skipping CODE refs, they are differently scoped
16my @test_types = qw(SCALAR ARRAY HASH GLOB);
17
18### The id() function
19{
20    my $ref = [];
21    is id( $ref), refaddr( $ref), "id is refaddr";
22    my %h;
23    Hash::Util::FieldHash::_fieldhash \ %h, $fieldhash_mode;
24    $h{ $ref} = ();
25    my ( $key) = keys %h;
26    is id( $ref), $key, "id is FieldHash key";
27    my $scalar = 'string';
28    is id( $scalar), $scalar, "string passes unchanged";
29    $scalar = 1234;
30    is id( $scalar), $scalar, "number passes unchanged";
31}
32
33### idhash functionality
34{
35    Hash::Util::FieldHash::idhash my %h;
36    my $ref = sub {};
37    my $val = 123;
38    $h{ $ref} = $val;
39    my ( $key) = keys %h;
40    is $key, id( $ref), "idhash key correct";
41    is $h{ $ref}, $val, "value retrieved through ref";
42    is scalar keys %$ob_reg, 0, "no auto-registry in idhash";
43}
44
45### the register() and id_2obj functions
46{
47    my $obj = {};
48    my $id = id( $obj);
49    is id_2obj( $id), undef, "unregistered object not retrieved";
50    is scalar keys %$ob_reg, 0, "object registry empty";
51    is register( $obj), $obj, "object returned by register";
52    is scalar keys %$ob_reg, 1, "object registry nonempty";
53    is id_2obj( $id), $obj, "registered object retrieved";
54    my %hash;
55    register( $obj, \ %hash);
56    $hash{ $id} = 123;
57    is scalar keys %hash, 1, "key present in registered hash";
58    undef $obj;
59    is scalar keys %hash, 0, "key collected from registered hash";
60    is scalar keys %$ob_reg, 0, "object registry empty again";
61    eval { register( 1234) };
62    like $@, qr/^Attempt to register/, "registering non-ref is fatal";
63}
64
65### Object auto-registry
66{
67    {
68        my $obj = {};
69        {
70            my $h = {};
71            Hash::Util::FieldHash::_fieldhash $h, $fieldhash_mode;
72            $h->{ $obj} = 123;
73            is( keys %$ob_reg, 1, "one object registered");
74        }
75        # field hash stays alive until $obj dies
76        is( keys %$ob_reg, 1, "object still registered");
77    }
78    is( keys %$ob_reg, 0, "object unregistered");
79}
80
81### existence/retrieval/deletion
82{
83    no warnings 'misc';
84    my $val = 123;
85    Hash::Util::FieldHash::_fieldhash \ my( %h), $fieldhash_mode;
86    for ( [ str => 'abc'], [ ref => {}] ) {
87        my ( $keytype, $key) = @$_;
88        $h{ $key} = $val;
89        ok( exists $h{ $key},  "existence ($keytype)");
90        is( $h{ $key}, $val,   "retrieval ($keytype)");
91        delete $h{ $key};
92        is( keys %h, 0, "deletion ($keytype)");
93    }
94}
95
96### id-action (stringification independent of bless)
97{
98    my( %f, %g, %h, %i);
99    Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
100    Hash::Util::FieldHash::_fieldhash \ %g, $fieldhash_mode;
101    my $val = 123;
102    my $key = [];
103    $f{ $key} = $val;
104    is( $f{ $key}, $val, "plain key set in field");
105    my ( $id) = keys %f;
106    my $refaddr = refaddr($key);
107    is $id, $refaddr, "key is refaddr";
108    bless $key;
109    is( $f{ $key}, $val, "access through blessed");
110    $key = [];
111    $h{ $key} = $val;
112    is( $h{ $key}, $val, "plain key set in hash");
113    bless $key;
114    isnt( $h{ $key}, $val, "no access through blessed");
115}
116
117# Garbage collection
118{
119    my %h;
120    Hash::Util::FieldHash::_fieldhash \ %h, $fieldhash_mode;
121    my $ar = [];
122    $h{$ar} = 123;
123    is( keys %h, 1, "blip");
124    undef $ar;
125    is( keys %h, 0, "blop");
126}
127
128for my $preload ( [], [ map {}, 1 .. 3] ) {
129    my $pre = @$preload ? ' (preloaded)' : '';
130    my %f;
131    Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
132    my @preval = map "$_", @$preload;
133    @f{ @$preload} = @preval;
134    # Garbage collection separately
135    for my $type ( @test_types) {
136        {
137            my $ref = gen_ref( $type);
138            $f{ $ref} = $type;
139            my ( $val) = grep $_ eq $type, values %f;
140            is( $val, $type, "$type visible$pre");
141            is(
142                keys %$ob_reg,
143                1 + @$preload,
144                "$type obj registered$pre"
145            );
146        }
147        is( keys %f, @$preload, "$type gone$pre");
148    }
149
150    # Garbage collection collectively
151    is( keys %$ob_reg, @$preload, "no objs remaining$pre");
152    {
153        my @refs = map gen_ref( $_), @test_types;
154        @f{ @refs} = @test_types;
155        is_deeply(
156            [ sort values %f], [ sort ( @test_types, @preval) ],
157            "all types present$pre",
158        );
159        is(
160            keys %$ob_reg,
161            @test_types + @$preload,
162            "all types registered$pre",
163        );
164    }
165    die "preload gone" unless defined $preload;
166    is_deeply( [ sort values %f], [ sort @preval], "all types gone$pre");
167    is( keys %$ob_reg, @$preload, "all types unregistered$pre");
168}
169is( keys %$ob_reg, 0, "preload gone after loop");
170
171# autovivified key
172{
173    my %h;
174    Hash::Util::FieldHash::_fieldhash \ %h, $fieldhash_mode;
175    my $ref = {};
176    my $x = $h{ $ref}->[ 0];
177    is keys %h, 1, "autovivified key present";
178    undef $ref;
179    is keys %h, 0, "autovivified key collected";
180}
181
182# big key sets
183{
184    my $size = 10_000;
185    my %f;
186    Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
187    {
188        my @refs = map [], 1 .. $size;
189        $f{ $_} = 1 for @refs;
190        is( keys %f, $size, "many keys singly");
191        is(
192            keys %$ob_reg,
193            $size,
194            "many objects singly",
195        );
196    }
197    is( keys %f, 0, "many keys singly gone");
198    is(
199        keys %$ob_reg,
200        0,
201        "many objects singly unregistered",
202    );
203
204    {
205        my @refs = map [], 1 .. $size;
206        @f{ @refs } = ( 1) x @refs;
207        is( keys %f, $size, "many keys at once");
208        is(
209            keys %$ob_reg,
210            $size,
211            "many objects at once",
212        );
213    }
214    is( keys %f, 0, "many keys at once gone");
215    is(
216        keys %$ob_reg,
217        0,
218        "many objects at once unregistered",
219    );
220}
221
222# many field hashes
223{
224    my $n_fields = 1000;
225    my @fields = map {}, $n_fields;
226    Hash::Util::FieldHash::_fieldhash( $_, $fieldhash_mode) for @fields;
227    my @obs = map gen_ref( $_), @test_types;
228    my $n_obs = @obs;
229    for my $field ( @fields ) {
230        @{ $field }{ @obs} = map ref, @obs;
231    }
232    my $err = grep keys %$_ != @obs, @fields;
233    is( $err, 0, "$n_obs entries in $n_fields fields");
234    is( keys %$ob_reg, @obs, "$n_obs obs registered");
235    pop @obs;
236    $err = grep keys %$_ != @obs, @fields;
237    is( $err, 0, "one entry gone from $n_fields fields");
238    is( keys %$ob_reg, @obs, "one ob unregistered");
239    @obs = ();
240    $err = grep keys %$_ != @obs, @fields;
241    is( $err, 0, "all entries gone from $n_fields fields");
242    is( keys %$ob_reg, @obs, "all obs unregistered");
243}
244
245
246# direct hash assignment
247{
248    Hash::Util::FieldHash::_fieldhash( $_, $fieldhash_mode) for \ my( %f, %g, %h);
249    my $size = 6;
250    my @obs = map [], 1 .. $size;
251    @f{ @obs} = ( 1) x $size;
252    $g{ $_} = $f{ $_} for keys %f; # single assignment
253    %h = %f;                       # wholesale assignment
254    @obs = ();
255    is keys %$ob_reg, 0, "all keys collected";
256    is keys %f, 0, "orig garbage-collected";
257    is keys %g, 0, "single-copy garbage-collected";
258    is keys %h, 0, "wholesale-copy garbage-collected";
259}
260
261{
262    # prototypes in place?
263    my %proto_tab = (
264        fieldhash   => '\\%',
265        fieldhashes => '',
266        idhash      => '\\%',
267        idhashes    => '',
268        id          => '$',
269        id_2obj     => '$',
270        register    => '$@',
271    );
272
273
274    my @notfound = grep !exists $proto_tab{ $_} =>
275        @Hash::Util::FieldHash::EXPORT_OK;
276    ok @notfound == 0, "All exports in table";
277    is prototype( "Hash::Util::FieldHash::$_") || '', $proto_tab{ $_},
278        "$_ has prototype ($proto_tab{ $_})" for
279            @Hash::Util::FieldHash::EXPORT_OK;
280}
281
282{
283    Hash::Util::FieldHash::_fieldhash \ my( %h), $fieldhash_mode;
284    bless \ %h, 'abc'; # this bus-errors with a certain bug
285    ok( 1, "no bus error on bless")
286}
287
288#######################################################################
289
290use Symbol qw( gensym);
291
292BEGIN {
293    my %gen = (
294        SCALAR => sub { \ my $o },
295        ARRAY  => sub { [] },
296        HASH   => sub { {} },
297        GLOB   => sub { gensym },
298        CODE   => sub { sub {} },
299    );
300
301    sub gen_ref { $gen{ shift()}->() }
302}
303
304done_testing;
305