xref: /openbsd-src/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/t/02_function.t (revision 5486feefcc8cb79b19e014ab332cc5dfd05b3b33)
1256a93a4Safresh1use strict;
2256a93a4Safresh1use warnings;
3256a93a4Safresh1no warnings 'experimental::builtin';
4256a93a4Safresh1use builtin qw(refaddr);
543003dfeSmillert
6256a93a4Safresh1use Test::More;
743003dfeSmillertuse Hash::Util::FieldHash qw( :all);
843003dfeSmillertmy $ob_reg = Hash::Util::FieldHash::_ob_reg;
943003dfeSmillert
1043003dfeSmillert#########################
1143003dfeSmillert
1243003dfeSmillertmy $fieldhash_mode = 2;
1343003dfeSmillert
1443003dfeSmillert# define ref types to use with some tests
1543003dfeSmillert# skipping CODE refs, they are differently scoped
16256a93a4Safresh1my @test_types = qw(SCALAR ARRAY HASH GLOB);
1743003dfeSmillert
1843003dfeSmillert### The id() function
1943003dfeSmillert{
2043003dfeSmillert    my $ref = [];
2143003dfeSmillert    is id( $ref), refaddr( $ref), "id is refaddr";
2243003dfeSmillert    my %h;
2343003dfeSmillert    Hash::Util::FieldHash::_fieldhash \ %h, $fieldhash_mode;
2443003dfeSmillert    $h{ $ref} = ();
2543003dfeSmillert    my ( $key) = keys %h;
2643003dfeSmillert    is id( $ref), $key, "id is FieldHash key";
2743003dfeSmillert    my $scalar = 'string';
2843003dfeSmillert    is id( $scalar), $scalar, "string passes unchanged";
2943003dfeSmillert    $scalar = 1234;
3043003dfeSmillert    is id( $scalar), $scalar, "number passes unchanged";
3143003dfeSmillert}
3243003dfeSmillert
3343003dfeSmillert### idhash functionality
3443003dfeSmillert{
3543003dfeSmillert    Hash::Util::FieldHash::idhash my %h;
3643003dfeSmillert    my $ref = sub {};
3743003dfeSmillert    my $val = 123;
3843003dfeSmillert    $h{ $ref} = $val;
3943003dfeSmillert    my ( $key) = keys %h;
4043003dfeSmillert    is $key, id( $ref), "idhash key correct";
4143003dfeSmillert    is $h{ $ref}, $val, "value retrieved through ref";
4243003dfeSmillert    is scalar keys %$ob_reg, 0, "no auto-registry in idhash";
4343003dfeSmillert}
4443003dfeSmillert
4543003dfeSmillert### the register() and id_2obj functions
4643003dfeSmillert{
4743003dfeSmillert    my $obj = {};
4843003dfeSmillert    my $id = id( $obj);
4943003dfeSmillert    is id_2obj( $id), undef, "unregistered object not retrieved";
5043003dfeSmillert    is scalar keys %$ob_reg, 0, "object registry empty";
5143003dfeSmillert    is register( $obj), $obj, "object returned by register";
5243003dfeSmillert    is scalar keys %$ob_reg, 1, "object registry nonempty";
5343003dfeSmillert    is id_2obj( $id), $obj, "registered object retrieved";
5443003dfeSmillert    my %hash;
5543003dfeSmillert    register( $obj, \ %hash);
5643003dfeSmillert    $hash{ $id} = 123;
5743003dfeSmillert    is scalar keys %hash, 1, "key present in registered hash";
5843003dfeSmillert    undef $obj;
5943003dfeSmillert    is scalar keys %hash, 0, "key collected from registered hash";
6043003dfeSmillert    is scalar keys %$ob_reg, 0, "object registry empty again";
6143003dfeSmillert    eval { register( 1234) };
6243003dfeSmillert    like $@, qr/^Attempt to register/, "registering non-ref is fatal";
6343003dfeSmillert}
6443003dfeSmillert
6543003dfeSmillert### Object auto-registry
6643003dfeSmillert{
6743003dfeSmillert    {
6843003dfeSmillert        my $obj = {};
6943003dfeSmillert        {
7043003dfeSmillert            my $h = {};
7143003dfeSmillert            Hash::Util::FieldHash::_fieldhash $h, $fieldhash_mode;
7243003dfeSmillert            $h->{ $obj} = 123;
7343003dfeSmillert            is( keys %$ob_reg, 1, "one object registered");
7443003dfeSmillert        }
7543003dfeSmillert        # field hash stays alive until $obj dies
7643003dfeSmillert        is( keys %$ob_reg, 1, "object still registered");
7743003dfeSmillert    }
7843003dfeSmillert    is( keys %$ob_reg, 0, "object unregistered");
7943003dfeSmillert}
8043003dfeSmillert
8143003dfeSmillert### existence/retrieval/deletion
8243003dfeSmillert{
8343003dfeSmillert    no warnings 'misc';
8443003dfeSmillert    my $val = 123;
8543003dfeSmillert    Hash::Util::FieldHash::_fieldhash \ my( %h), $fieldhash_mode;
8643003dfeSmillert    for ( [ str => 'abc'], [ ref => {}] ) {
8743003dfeSmillert        my ( $keytype, $key) = @$_;
8843003dfeSmillert        $h{ $key} = $val;
8943003dfeSmillert        ok( exists $h{ $key},  "existence ($keytype)");
9043003dfeSmillert        is( $h{ $key}, $val,   "retrieval ($keytype)");
9143003dfeSmillert        delete $h{ $key};
9243003dfeSmillert        is( keys %h, 0, "deletion ($keytype)");
9343003dfeSmillert    }
9443003dfeSmillert}
9543003dfeSmillert
9643003dfeSmillert### id-action (stringification independent of bless)
9743003dfeSmillert{
9843003dfeSmillert    my( %f, %g, %h, %i);
9943003dfeSmillert    Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
10043003dfeSmillert    Hash::Util::FieldHash::_fieldhash \ %g, $fieldhash_mode;
10143003dfeSmillert    my $val = 123;
10243003dfeSmillert    my $key = [];
10343003dfeSmillert    $f{ $key} = $val;
10443003dfeSmillert    is( $f{ $key}, $val, "plain key set in field");
10543003dfeSmillert    my ( $id) = keys %f;
10643003dfeSmillert    my $refaddr = refaddr($key);
10743003dfeSmillert    is $id, $refaddr, "key is refaddr";
10843003dfeSmillert    bless $key;
10943003dfeSmillert    is( $f{ $key}, $val, "access through blessed");
11043003dfeSmillert    $key = [];
11143003dfeSmillert    $h{ $key} = $val;
11243003dfeSmillert    is( $h{ $key}, $val, "plain key set in hash");
11343003dfeSmillert    bless $key;
11443003dfeSmillert    isnt( $h{ $key}, $val, "no access through blessed");
11543003dfeSmillert}
11643003dfeSmillert
11743003dfeSmillert# Garbage collection
11843003dfeSmillert{
11943003dfeSmillert    my %h;
12043003dfeSmillert    Hash::Util::FieldHash::_fieldhash \ %h, $fieldhash_mode;
121*5486feefSafresh1    my $ar = [];
122*5486feefSafresh1    $h{$ar} = 123;
123*5486feefSafresh1    is( keys %h, 1, "blip");
124*5486feefSafresh1    undef $ar;
125*5486feefSafresh1    is( keys %h, 0, "blop");
12643003dfeSmillert}
12743003dfeSmillert
12843003dfeSmillertfor my $preload ( [], [ map {}, 1 .. 3] ) {
12943003dfeSmillert    my $pre = @$preload ? ' (preloaded)' : '';
13043003dfeSmillert    my %f;
13143003dfeSmillert    Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
13243003dfeSmillert    my @preval = map "$_", @$preload;
13343003dfeSmillert    @f{ @$preload} = @preval;
13443003dfeSmillert    # Garbage collection separately
13543003dfeSmillert    for my $type ( @test_types) {
13643003dfeSmillert        {
13743003dfeSmillert            my $ref = gen_ref( $type);
13843003dfeSmillert            $f{ $ref} = $type;
13943003dfeSmillert            my ( $val) = grep $_ eq $type, values %f;
14043003dfeSmillert            is( $val, $type, "$type visible$pre");
14143003dfeSmillert            is(
14243003dfeSmillert                keys %$ob_reg,
14343003dfeSmillert                1 + @$preload,
14443003dfeSmillert                "$type obj registered$pre"
14543003dfeSmillert            );
14643003dfeSmillert        }
14743003dfeSmillert        is( keys %f, @$preload, "$type gone$pre");
14843003dfeSmillert    }
14943003dfeSmillert
15043003dfeSmillert    # Garbage collection collectively
15143003dfeSmillert    is( keys %$ob_reg, @$preload, "no objs remaining$pre");
15243003dfeSmillert    {
15343003dfeSmillert        my @refs = map gen_ref( $_), @test_types;
15443003dfeSmillert        @f{ @refs} = @test_types;
155256a93a4Safresh1        is_deeply(
156256a93a4Safresh1            [ sort values %f], [ sort ( @test_types, @preval) ],
15743003dfeSmillert            "all types present$pre",
15843003dfeSmillert        );
15943003dfeSmillert        is(
16043003dfeSmillert            keys %$ob_reg,
16143003dfeSmillert            @test_types + @$preload,
16243003dfeSmillert            "all types registered$pre",
16343003dfeSmillert        );
16443003dfeSmillert    }
16543003dfeSmillert    die "preload gone" unless defined $preload;
166256a93a4Safresh1    is_deeply( [ sort values %f], [ sort @preval], "all types gone$pre");
16743003dfeSmillert    is( keys %$ob_reg, @$preload, "all types unregistered$pre");
16843003dfeSmillert}
16943003dfeSmillertis( keys %$ob_reg, 0, "preload gone after loop");
17043003dfeSmillert
17143003dfeSmillert# autovivified key
17243003dfeSmillert{
17343003dfeSmillert    my %h;
17443003dfeSmillert    Hash::Util::FieldHash::_fieldhash \ %h, $fieldhash_mode;
17543003dfeSmillert    my $ref = {};
17643003dfeSmillert    my $x = $h{ $ref}->[ 0];
17743003dfeSmillert    is keys %h, 1, "autovivified key present";
17843003dfeSmillert    undef $ref;
17943003dfeSmillert    is keys %h, 0, "autovivified key collected";
18043003dfeSmillert}
18143003dfeSmillert
18243003dfeSmillert# big key sets
18343003dfeSmillert{
18443003dfeSmillert    my $size = 10_000;
18543003dfeSmillert    my %f;
18643003dfeSmillert    Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
18743003dfeSmillert    {
18843003dfeSmillert        my @refs = map [], 1 .. $size;
18943003dfeSmillert        $f{ $_} = 1 for @refs;
19043003dfeSmillert        is( keys %f, $size, "many keys singly");
19143003dfeSmillert        is(
19243003dfeSmillert            keys %$ob_reg,
19343003dfeSmillert            $size,
19443003dfeSmillert            "many objects singly",
19543003dfeSmillert        );
19643003dfeSmillert    }
19743003dfeSmillert    is( keys %f, 0, "many keys singly gone");
19843003dfeSmillert    is(
19943003dfeSmillert        keys %$ob_reg,
20043003dfeSmillert        0,
20143003dfeSmillert        "many objects singly unregistered",
20243003dfeSmillert    );
20343003dfeSmillert
20443003dfeSmillert    {
20543003dfeSmillert        my @refs = map [], 1 .. $size;
20643003dfeSmillert        @f{ @refs } = ( 1) x @refs;
20743003dfeSmillert        is( keys %f, $size, "many keys at once");
20843003dfeSmillert        is(
20943003dfeSmillert            keys %$ob_reg,
21043003dfeSmillert            $size,
21143003dfeSmillert            "many objects at once",
21243003dfeSmillert        );
21343003dfeSmillert    }
21443003dfeSmillert    is( keys %f, 0, "many keys at once gone");
21543003dfeSmillert    is(
21643003dfeSmillert        keys %$ob_reg,
21743003dfeSmillert        0,
21843003dfeSmillert        "many objects at once unregistered",
21943003dfeSmillert    );
22043003dfeSmillert}
22143003dfeSmillert
22243003dfeSmillert# many field hashes
22343003dfeSmillert{
22443003dfeSmillert    my $n_fields = 1000;
22543003dfeSmillert    my @fields = map {}, $n_fields;
22643003dfeSmillert    Hash::Util::FieldHash::_fieldhash( $_, $fieldhash_mode) for @fields;
22743003dfeSmillert    my @obs = map gen_ref( $_), @test_types;
22843003dfeSmillert    my $n_obs = @obs;
22943003dfeSmillert    for my $field ( @fields ) {
23043003dfeSmillert        @{ $field }{ @obs} = map ref, @obs;
23143003dfeSmillert    }
23243003dfeSmillert    my $err = grep keys %$_ != @obs, @fields;
23343003dfeSmillert    is( $err, 0, "$n_obs entries in $n_fields fields");
23443003dfeSmillert    is( keys %$ob_reg, @obs, "$n_obs obs registered");
23543003dfeSmillert    pop @obs;
23643003dfeSmillert    $err = grep keys %$_ != @obs, @fields;
23743003dfeSmillert    is( $err, 0, "one entry gone from $n_fields fields");
23843003dfeSmillert    is( keys %$ob_reg, @obs, "one ob unregistered");
23943003dfeSmillert    @obs = ();
24043003dfeSmillert    $err = grep keys %$_ != @obs, @fields;
24143003dfeSmillert    is( $err, 0, "all entries gone from $n_fields fields");
24243003dfeSmillert    is( keys %$ob_reg, @obs, "all obs unregistered");
24343003dfeSmillert}
24443003dfeSmillert
24543003dfeSmillert
24643003dfeSmillert# direct hash assignment
24743003dfeSmillert{
24843003dfeSmillert    Hash::Util::FieldHash::_fieldhash( $_, $fieldhash_mode) for \ my( %f, %g, %h);
24943003dfeSmillert    my $size = 6;
25043003dfeSmillert    my @obs = map [], 1 .. $size;
25143003dfeSmillert    @f{ @obs} = ( 1) x $size;
25243003dfeSmillert    $g{ $_} = $f{ $_} for keys %f; # single assignment
25343003dfeSmillert    %h = %f;                       # wholesale assignment
25443003dfeSmillert    @obs = ();
25543003dfeSmillert    is keys %$ob_reg, 0, "all keys collected";
25643003dfeSmillert    is keys %f, 0, "orig garbage-collected";
25743003dfeSmillert    is keys %g, 0, "single-copy garbage-collected";
25843003dfeSmillert    is keys %h, 0, "wholesale-copy garbage-collected";
25943003dfeSmillert}
26043003dfeSmillert
26143003dfeSmillert{
26243003dfeSmillert    # prototypes in place?
26343003dfeSmillert    my %proto_tab = (
26443003dfeSmillert        fieldhash   => '\\%',
26543003dfeSmillert        fieldhashes => '',
26643003dfeSmillert        idhash      => '\\%',
26743003dfeSmillert        idhashes    => '',
26843003dfeSmillert        id          => '$',
26943003dfeSmillert        id_2obj     => '$',
27043003dfeSmillert        register    => '$@',
27143003dfeSmillert    );
27243003dfeSmillert
27343003dfeSmillert
27443003dfeSmillert    my @notfound = grep !exists $proto_tab{ $_} =>
27543003dfeSmillert        @Hash::Util::FieldHash::EXPORT_OK;
27643003dfeSmillert    ok @notfound == 0, "All exports in table";
27743003dfeSmillert    is prototype( "Hash::Util::FieldHash::$_") || '', $proto_tab{ $_},
27843003dfeSmillert        "$_ has prototype ($proto_tab{ $_})" for
27943003dfeSmillert            @Hash::Util::FieldHash::EXPORT_OK;
28043003dfeSmillert}
28143003dfeSmillert
28243003dfeSmillert{
28343003dfeSmillert    Hash::Util::FieldHash::_fieldhash \ my( %h), $fieldhash_mode;
28443003dfeSmillert    bless \ %h, 'abc'; # this bus-errors with a certain bug
28543003dfeSmillert    ok( 1, "no bus error on bless")
28643003dfeSmillert}
28743003dfeSmillert
28843003dfeSmillert#######################################################################
28943003dfeSmillert
29043003dfeSmillertuse Symbol qw( gensym);
29143003dfeSmillert
29243003dfeSmillertBEGIN {
29343003dfeSmillert    my %gen = (
29443003dfeSmillert        SCALAR => sub { \ my $o },
29543003dfeSmillert        ARRAY  => sub { [] },
29643003dfeSmillert        HASH   => sub { {} },
29743003dfeSmillert        GLOB   => sub { gensym },
29843003dfeSmillert        CODE   => sub { sub {} },
29943003dfeSmillert    );
30043003dfeSmillert
30143003dfeSmillert    sub gen_ref { $gen{ shift()}->() }
30243003dfeSmillert}
303256a93a4Safresh1
304256a93a4Safresh1done_testing;
305