#########################
+my $fieldhash_mode = 2;
+
# define ref types to use with some tests
my @test_types;
BEGIN {
@test_types = qw( SCALAR ARRAY HASH GLOB);
}
-### Object registry
+### The id() function
+{
+ BEGIN { $n_tests += 4 }
+ my $ref = [];
+ is id( $ref), refaddr( $ref), "id is refaddr";
+ my %h;
+ Hash::Util::FieldHash::_fieldhash \ %h, $fieldhash_mode;
+ $h{ $ref} = ();
+ my ( $key) = keys %h;
+ is id( $ref), $key, "id is FieldHash key";
+ my $scalar = 'string';
+ is id( $scalar), $scalar, "string passes unchanged";
+ $scalar = 1234;
+ is id( $scalar), $scalar, "number passes unchanged";
+}
+
+### idhash functionality
+{
+ BEGIN { $n_tests += 3 }
+ Hash::Util::FieldHash::idhash my %h;
+ my $ref = sub {};
+ my $val = 123;
+ $h{ $ref} = $val;
+ my ( $key) = keys %h;
+ is $key, id( $ref), "idhash key correct";
+ is $h{ $ref}, $val, "value retrieved through ref";
+ is scalar keys %$ob_reg, 0, "no auto-registry in idhash";
+}
+
+### the register() and id_2obj functions
+{
+ BEGIN { $n_tests += 9 }
+ my $obj = {};
+ my $id = id( $obj);
+ is id_2obj( $id), undef, "unregistered object not retrieved";
+ is scalar keys %$ob_reg, 0, "object registry empty";
+ is register( $obj), $obj, "object returned by register";
+ is scalar keys %$ob_reg, 1, "object registry nonempty";
+ is id_2obj( $id), $obj, "registered object retrieved";
+ my %hash;
+ register( $obj, \ %hash);
+ $hash{ $id} = 123;
+ is scalar keys %hash, 1, "key present in registered hash";
+ undef $obj;
+ is scalar keys %hash, 0, "key collected from registered hash";
+ is scalar keys %$ob_reg, 0, "object registry empty again";
+ eval { register( 1234) };
+ like $@, qr/^Attempt to register/, "registering non-ref is fatal";
+
+}
+
+### Object auto-registry
BEGIN { $n_tests += 3 }
{
{
my $obj = {};
{
- my $h;
- fieldhash %$h;
+ my $h = {};
+ Hash::Util::FieldHash::_fieldhash $h, $fieldhash_mode;
$h->{ $obj} = 123;
is( keys %$ob_reg, 1, "one object registered");
}
{
no warnings 'misc';
my $val = 123;
- fieldhash my %h;
+ Hash::Util::FieldHash::_fieldhash \ my( %h), $fieldhash_mode;
for ( [ str => 'abc'], [ ref => {}] ) {
my ( $keytype, $key) = @$_;
$h{ $key} = $val;
}
### id-action (stringification independent of bless)
-BEGIN { $n_tests += 4 }
+BEGIN { $n_tests += 5 }
+# use Scalar::Util qw( refaddr);
{
my( %f, %g, %h, %i);
- fieldhash %f;
- fieldhash %g;
+ Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
+ Hash::Util::FieldHash::_fieldhash \ %g, $fieldhash_mode;
my $val = 123;
my $key = [];
$f{ $key} = $val;
is( $f{ $key}, $val, "plain key set in field");
+ my ( $id) = keys %f;
+ my $refaddr = hex +($key =~ /\(0x([[:xdigit:]]+)\)$/)[ 0];
+ is $id, $refaddr, "key is refaddr";
bless $key;
is( $f{ $key}, $val, "access through blessed");
$key = [];
}
# Garbage collection
-BEGIN { $n_tests += 1 + 2*( 3*@test_types + 5) + 1 }
+BEGIN { $n_tests += 1 + 2*( 3*@test_types + 5) + 1 + 2 }
{
- fieldhash my %h;
+ my %h;
+ Hash::Util::FieldHash::_fieldhash \ %h, $fieldhash_mode;
$h{ []} = 123;
is( keys %h, 0, "blip");
}
for my $preload ( [], [ map {}, 1 .. 3] ) {
my $pre = @$preload ? ' (preloaded)' : '';
- fieldhash my %f;
+ my %f;
+ Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
my @preval = map "$_", @$preload;
@f{ @$preload} = @preval;
# Garbage collection separately
}
is( keys %$ob_reg, 0, "preload gone after loop");
+# autovivified key
+{
+ my %h;
+ Hash::Util::FieldHash::_fieldhash \ %h, $fieldhash_mode;
+ my $ref = {};
+ my $x = $h{ $ref}->[ 0];
+ is keys %h, 1, "autovivified key present";
+ undef $ref;
+ is keys %h, 0, "autovivified key collected";
+}
+
# big key sets
BEGIN { $n_tests += 8 }
{
my $size = 10_000;
- fieldhash( my %f);
+ my %f;
+ Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
{
my @refs = map [], 1 .. $size;
$f{ $_} = 1 for @refs;
BEGIN { $n_tests += 6 }
{
my $n_fields = 1000;
- my @fields = map &fieldhash( {}), 1 .. $n_fields;
+ my @fields = map {}, $n_fields;
+ Hash::Util::FieldHash::_fieldhash( $_, $fieldhash_mode) for @fields;
my @obs = map gen_ref( $_), @test_types;
my $n_obs = @obs;
for my $field ( @fields ) {
is( keys %$ob_reg, @obs, "all obs unregistered");
}
+
+# direct hash assignment
+BEGIN { $n_tests += 4 }
{
+ Hash::Util::FieldHash::_fieldhash( $_, $fieldhash_mode) for \ my( %f, %g, %h);
+ my $size = 6;
+ my @obs = map [], 1 .. $size;
+ @f{ @obs} = ( 1) x $size;
+ $g{ $_} = $f{ $_} for keys %f; # single assignment
+ %h = %f; # wholesale assignment
+ @obs = ();
+ is keys %$ob_reg, 0, "all keys collected";
+ is keys %f, 0, "orig garbage-collected";
+ is keys %g, 0, "single-copy garbage-collected";
+ is keys %h, 0, "wholesale-copy garbage-collected";
+}
+{
BEGIN { $n_tests += 1 }
- fieldhash my %h;
+ Hash::Util::FieldHash::_fieldhash \ my( %h), $fieldhash_mode;
bless \ %h, 'abc'; # this bus-errors with a certain bug
ok( 1, "no bus error on bless")
}
#######################################################################
+sub refaddr {
+ my $ref = shift;
+ hex +($ref =~ /\(0x([[:xdigit:]]+)\)$/)[ 0];
+}
+
use Symbol qw( gensym);
BEGIN {
my %gen = (
- SCALAR => sub { \ my $x },
+ SCALAR => sub { \ my $o },
ARRAY => sub { [] },
HASH => sub { {} },
GLOB => sub { gensym },