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