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