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