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    $h{ []} = 123;
122    is( keys %h, 0, "blip");
123}
124
125for my $preload ( [], [ map {}, 1 .. 3] ) {
126    my $pre = @$preload ? ' (preloaded)' : '';
127    my %f;
128    Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
129    my @preval = map "$_", @$preload;
130    @f{ @$preload} = @preval;
131    # Garbage collection separately
132    for my $type ( @test_types) {
133        {
134            my $ref = gen_ref( $type);
135            $f{ $ref} = $type;
136            my ( $val) = grep $_ eq $type, values %f;
137            is( $val, $type, "$type visible$pre");
138            is(
139                keys %$ob_reg,
140                1 + @$preload,
141                "$type obj registered$pre"
142            );
143        }
144        is( keys %f, @$preload, "$type gone$pre");
145    }
146
147    # Garbage collection collectively
148    is( keys %$ob_reg, @$preload, "no objs remaining$pre");
149    {
150        my @refs = map gen_ref( $_), @test_types;
151        @f{ @refs} = @test_types;
152        is_deeply(
153            [ sort values %f], [ sort ( @test_types, @preval) ],
154            "all types present$pre",
155        );
156        is(
157            keys %$ob_reg,
158            @test_types + @$preload,
159            "all types registered$pre",
160        );
161    }
162    die "preload gone" unless defined $preload;
163    is_deeply( [ sort values %f], [ sort @preval], "all types gone$pre");
164    is( keys %$ob_reg, @$preload, "all types unregistered$pre");
165}
166is( keys %$ob_reg, 0, "preload gone after loop");
167
168# autovivified key
169{
170    my %h;
171    Hash::Util::FieldHash::_fieldhash \ %h, $fieldhash_mode;
172    my $ref = {};
173    my $x = $h{ $ref}->[ 0];
174    is keys %h, 1, "autovivified key present";
175    undef $ref;
176    is keys %h, 0, "autovivified key collected";
177}
178
179# big key sets
180{
181    my $size = 10_000;
182    my %f;
183    Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
184    {
185        my @refs = map [], 1 .. $size;
186        $f{ $_} = 1 for @refs;
187        is( keys %f, $size, "many keys singly");
188        is(
189            keys %$ob_reg,
190            $size,
191            "many objects singly",
192        );
193    }
194    is( keys %f, 0, "many keys singly gone");
195    is(
196        keys %$ob_reg,
197        0,
198        "many objects singly unregistered",
199    );
200
201    {
202        my @refs = map [], 1 .. $size;
203        @f{ @refs } = ( 1) x @refs;
204        is( keys %f, $size, "many keys at once");
205        is(
206            keys %$ob_reg,
207            $size,
208            "many objects at once",
209        );
210    }
211    is( keys %f, 0, "many keys at once gone");
212    is(
213        keys %$ob_reg,
214        0,
215        "many objects at once unregistered",
216    );
217}
218
219# many field hashes
220{
221    my $n_fields = 1000;
222    my @fields = map {}, $n_fields;
223    Hash::Util::FieldHash::_fieldhash( $_, $fieldhash_mode) for @fields;
224    my @obs = map gen_ref( $_), @test_types;
225    my $n_obs = @obs;
226    for my $field ( @fields ) {
227        @{ $field }{ @obs} = map ref, @obs;
228    }
229    my $err = grep keys %$_ != @obs, @fields;
230    is( $err, 0, "$n_obs entries in $n_fields fields");
231    is( keys %$ob_reg, @obs, "$n_obs obs registered");
232    pop @obs;
233    $err = grep keys %$_ != @obs, @fields;
234    is( $err, 0, "one entry gone from $n_fields fields");
235    is( keys %$ob_reg, @obs, "one ob unregistered");
236    @obs = ();
237    $err = grep keys %$_ != @obs, @fields;
238    is( $err, 0, "all entries gone from $n_fields fields");
239    is( keys %$ob_reg, @obs, "all obs unregistered");
240}
241
242
243# direct hash assignment
244{
245    Hash::Util::FieldHash::_fieldhash( $_, $fieldhash_mode) for \ my( %f, %g, %h);
246    my $size = 6;
247    my @obs = map [], 1 .. $size;
248    @f{ @obs} = ( 1) x $size;
249    $g{ $_} = $f{ $_} for keys %f; # single assignment
250    %h = %f;                       # wholesale assignment
251    @obs = ();
252    is keys %$ob_reg, 0, "all keys collected";
253    is keys %f, 0, "orig garbage-collected";
254    is keys %g, 0, "single-copy garbage-collected";
255    is keys %h, 0, "wholesale-copy garbage-collected";
256}
257
258{
259    # prototypes in place?
260    my %proto_tab = (
261        fieldhash   => '\\%',
262        fieldhashes => '',
263        idhash      => '\\%',
264        idhashes    => '',
265        id          => '$',
266        id_2obj     => '$',
267        register    => '$@',
268    );
269
270
271    my @notfound = grep !exists $proto_tab{ $_} =>
272        @Hash::Util::FieldHash::EXPORT_OK;
273    ok @notfound == 0, "All exports in table";
274    is prototype( "Hash::Util::FieldHash::$_") || '', $proto_tab{ $_},
275        "$_ has prototype ($proto_tab{ $_})" for
276            @Hash::Util::FieldHash::EXPORT_OK;
277}
278
279{
280    Hash::Util::FieldHash::_fieldhash \ my( %h), $fieldhash_mode;
281    bless \ %h, 'abc'; # this bus-errors with a certain bug
282    ok( 1, "no bus error on bless")
283}
284
285#######################################################################
286
287use Symbol qw( gensym);
288
289BEGIN {
290    my %gen = (
291        SCALAR => sub { \ my $o },
292        ARRAY  => sub { [] },
293        HASH   => sub { {} },
294        GLOB   => sub { gensym },
295        CODE   => sub { sub {} },
296    );
297
298    sub gen_ref { $gen{ shift()}->() }
299}
300
301done_testing;
302