[p5sagit/p5-mst-13.2.git] / ext / Hash / Util / FieldHash / t / 02_function.t

#!perl

BEGIN {
    if ($ENV{PERL_CORE}) {
	chdir 't' if -d 't';
	@INC = '../lib';
    }
}

use strict; use warnings;
use Test::More;
my $n_tests = 0;

use Hash::Util::FieldHash qw( :all);
my $ob_reg = Hash::Util::FieldHash::_ob_reg;

#########################

my $fieldhash_mode = 2;

# define ref types to use with some tests
my @test_types;
BEGIN {
    # skipping CODE refs, they are differently scoped
    @test_types = qw( SCALAR ARRAY HASH GLOB);
}

### 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 = {};
            Hash::Util::FieldHash::_fieldhash $h, $fieldhash_mode;
            $h->{ $obj} = 123;
            is( keys %$ob_reg, 1, "one object registered");
        }
        # field hash stays alive until $obj dies
        is( keys %$ob_reg, 1, "object still registered");
    }
    is( keys %$ob_reg, 0, "object unregistered");
}

### existence/retrieval/deletion
BEGIN { $n_tests += 6 }
{
    no warnings 'misc';
    my $val = 123;
    Hash::Util::FieldHash::_fieldhash \ my( %h), $fieldhash_mode;
    for ( [ str => 'abc'], [ ref => {}] ) {
        my ( $keytype, $key) = @$_;
        $h{ $key} = $val;
        ok( exists $h{ $key},  "existence ($keytype)");
        is( $h{ $key}, $val,   "retrieval ($keytype)");
        delete $h{ $key};
        is( keys %h, 0, "deletion ($keytype)");
    }
}

### id-action (stringification independent of bless)
BEGIN { $n_tests += 5 }
# use Scalar::Util qw( refaddr);
{
    my( %f, %g, %h, %i);
    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 = [];
    $h{ $key} = $val;
    is( $h{ $key}, $val, "plain key set in hash");
    bless $key;
    isnt( $h{ $key}, $val, "no access through blessed");
}
    
# Garbage collection
BEGIN { $n_tests += 1 + 2*( 3*@test_types + 5) + 1 + 2 }

{
    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)' : '';
    my %f;
    Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
    my @preval = map "$_", @$preload;
    @f{ @$preload} = @preval;
    # Garbage collection separately
    for my $type ( @test_types) {
        {
            my $ref = gen_ref( $type);
            $f{ $ref} = $type;
            my ( $val) = grep $_ eq $type, values %f;
            is( $val, $type, "$type visible$pre");
            is( 
                keys %$ob_reg,
                1 + @$preload,
                "$type obj registered$pre"
            );
        }
        is( keys %f, @$preload, "$type gone$pre");
    }
    
    # Garbage collection collectively
    is( keys %$ob_reg, @$preload, "no objs remaining$pre");
    {
        my @refs = map gen_ref( $_), @test_types;
        @f{ @refs} = @test_types;
        ok(
            eq_set( [ values %f], [ @test_types, @preval]),
            "all types present$pre",
        );
        is(
            keys %$ob_reg,
            @test_types + @$preload,
            "all types registered$pre",
        );
    }
    die "preload gone" unless defined $preload;
    ok( eq_set( [ values %f], \ @preval), "all types gone$pre");
    is( keys %$ob_reg, @$preload, "all types unregistered$pre");
}
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;
    my %f;
    Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
    {
        my @refs = map [], 1 .. $size;
        $f{ $_} = 1 for @refs;
        is( keys %f, $size, "many keys singly");
        is(
            keys %$ob_reg,
            $size,
            "many objects singly",
        );
    }
    is( keys %f, 0, "many keys singly gone");
    is(
        keys %$ob_reg,
        0,
        "many objects singly unregistered",
    );
    
    {
        my @refs = map [], 1 .. $size;
        @f{ @refs } = ( 1) x @refs;
        is( keys %f, $size, "many keys at once");
        is(
            keys %$ob_reg,
            $size,
            "many objects at once",
        );
    }
    is( keys %f, 0, "many keys at once gone");
    is(
        keys %$ob_reg,
        0,
        "many objects at once unregistered",
    );
}

# many field hashes
BEGIN { $n_tests += 6 }
{
    my $n_fields = 1000;
    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 ) {
        @{ $field }{ @obs} = map ref, @obs;
    }
    my $err = grep keys %$_ != @obs, @fields;
    is( $err, 0, "$n_obs entries in $n_fields fields");
    is( keys %$ob_reg, @obs, "$n_obs obs registered");
    pop @obs;
    $err = grep keys %$_ != @obs, @fields;
    is( $err, 0, "one entry gone from $n_fields fields");
    is( keys %$ob_reg, @obs, "one ob unregistered");
    @obs = ();
    $err = grep keys %$_ != @obs, @fields;
    is( $err, 0, "all entries gone from $n_fields 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 }
    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")
}

BEGIN { plan tests => $n_tests }

#######################################################################

sub refaddr {
    my $ref = shift;
    hex +($ref =~ /\(0x([[:xdigit:]]+)\)$/)[ 0];
}

use Symbol qw( gensym);

BEGIN {
    my %gen = (
        SCALAR => sub { \ my $o },
        ARRAY  => sub { [] },
        HASH   => sub { {} },
        GLOB   => sub { gensym },
        CODE   => sub { sub {} },
    );

    sub gen_ref { $gen{ shift()}->() }
}
Commit	Line	Data
1e73acc8	1	#!perl
	2
	3	BEGIN {
df6ac08f	4	if ($ENV{PERL_CORE}) {
	5	chdir 't' if -d 't';
	6	@INC = '../lib';
	7	}
1e73acc8	8	}
	9
	10	use strict; use warnings;
	11	use Test::More;
	12	my $n_tests = 0;
	13
	14	use Hash::Util::FieldHash qw( :all);
6ff38c27	15	my $ob_reg = Hash::Util::FieldHash::_ob_reg;
1e73acc8	16
	17	#########################
	18
d74d639b	19	my $fieldhash_mode = 2;
d74d639b	20
1e73acc8	21	# define ref types to use with some tests
	22	my @test_types;
	23	BEGIN {
	24	# skipping CODE refs, they are differently scoped
	25	@test_types = qw( SCALAR ARRAY HASH GLOB);
	26	}
	27
d74d639b	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
1e73acc8	80
	81	BEGIN { $n_tests += 3 }
	82	{
1e73acc8	83	{
	84	my $obj = {};
	85	{
d74d639b	86	my $h = {};
d74d639b	87	Hash::Util::FieldHash::_fieldhash $h, $fieldhash_mode;
1e73acc8	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
	98	BEGIN { $n_tests += 6 }
	99	{
	100	no warnings 'misc';
	101	my $val = 123;
d74d639b	102	Hash::Util::FieldHash::_fieldhash \ my( %h), $fieldhash_mode;
1e73acc8	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)
d74d639b	114	BEGIN { $n_tests += 5 }
d74d639b	115	# use Scalar::Util qw( refaddr);
1e73acc8	116	{
1e73acc8	117	my( %f, %g, %h, %i);
d74d639b	118	Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
d74d639b	119	Hash::Util::FieldHash::_fieldhash \ %g, $fieldhash_mode;
1e73acc8	120	my $val = 123;
	121	my $key = [];
	122	$f{ $key} = $val;
	123	is( $f{ $key}, $val, "plain key set in field");
d74d639b	124	my ( $id) = keys %f;
	125	my $refaddr = hex +($key =~ /\(0x([[:xdigit:]]+)\)$/)[ 0];
	126	is $id, $refaddr, "key is refaddr";
1e73acc8	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
d74d639b	137	BEGIN { $n_tests += 1 + 2( 3@test_types + 5) + 1 + 2 }
1e73acc8	138
1e73acc8	139	{
d74d639b	140	my %h;
d74d639b	141	Hash::Util::FieldHash::_fieldhash \ %h, $fieldhash_mode;
1e73acc8	142	$h{ []} = 123;
	143	is( keys %h, 0, "blip");
	144	}
	145
	146	for my $preload ( [], [ map {}, 1 .. 3] ) {
	147	my $pre = @$preload ? ' (preloaded)' : '';
d74d639b	148	my %f;
d74d639b	149	Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
1e73acc8	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(
6ff38c27	160	keys %$ob_reg,
1e73acc8	161	1 + @$preload,
	162	"$type obj registered$pre"
	163	);
	164	}
	165	is( keys %f, @$preload, "$type gone$pre");
	166	}
	167
	168	# Garbage collection collectively
6ff38c27	169	is( keys %$ob_reg, @$preload, "no objs remaining$pre");
1e73acc8	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(
6ff38c27	178	keys %$ob_reg,
1e73acc8	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");
6ff38c27	185	is( keys %$ob_reg, @$preload, "all types unregistered$pre");
1e73acc8	186	}
6ff38c27	187	is( keys %$ob_reg, 0, "preload gone after loop");
1e73acc8	188
d74d639b	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
1e73acc8	200	# big key sets
	201	BEGIN { $n_tests += 8 }
	202	{
	203	my $size = 10_000;
d74d639b	204	my %f;
d74d639b	205	Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
1e73acc8	206	{
	207	my @refs = map [], 1 .. $size;
	208	$f{ $_} = 1 for @refs;
	209	is( keys %f, $size, "many keys singly");
	210	is(
6ff38c27	211	keys %$ob_reg,
1e73acc8	212	$size,
	213	"many objects singly",
	214	);
	215	}
	216	is( keys %f, 0, "many keys singly gone");
	217	is(
6ff38c27	218	keys %$ob_reg,
1e73acc8	219	0,
	220	"many objects singly unregistered",
	221	);
	222
	223	{
	224	my @refs = map [], 1 .. $size;
ce809d1f	225	@f{ @refs } = ( 1) x @refs;
1e73acc8	226	is( keys %f, $size, "many keys at once");
1e73acc8	227	is(
6ff38c27	228	keys %$ob_reg,
1e73acc8	229	$size,
	230	"many objects at once",
	231	);
	232	}
	233	is( keys %f, 0, "many keys at once gone");
	234	is(
6ff38c27	235	keys %$ob_reg,
1e73acc8	236	0,
	237	"many objects at once unregistered",
	238	);
	239	}
	240
	241	# many field hashes
	242	BEGIN { $n_tests += 6 }
	243	{
	244	my $n_fields = 1000;
d74d639b	245	my @fields = map {}, $n_fields;
d74d639b	246	Hash::Util::FieldHash::_fieldhash( $_, $fieldhash_mode) for @fields;
1e73acc8	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");
6ff38c27	254	is( keys %$ob_reg, @obs, "$n_obs obs registered");
1e73acc8	255	pop @obs;
	256	$err = grep keys %$_ != @obs, @fields;
	257	is( $err, 0, "one entry gone from $n_fields fields");
6ff38c27	258	is( keys %$ob_reg, @obs, "one ob unregistered");
1e73acc8	259	@obs = ();
	260	$err = grep keys %$_ != @obs, @fields;
	261	is( $err, 0, "all entries gone from $n_fields fields");
6ff38c27	262	is( keys %$ob_reg, @obs, "all obs unregistered");
1e73acc8	263	}
1e73acc8	264
d020b00b	265
	266	# direct hash assignment
	267	BEGIN { $n_tests += 4 }
	268	{
d74d639b	269	Hash::Util::FieldHash::_fieldhash( $_, $fieldhash_mode) for \ my( %f, %g, %h);
d020b00b	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";
e37bf7df	278	is keys %g, 0, "single-copy garbage-collected";
e37bf7df	279	is keys %h, 0, "wholesale-copy garbage-collected";
d020b00b	280	}
d020b00b	281
1e73acc8	282	{
1e73acc8	283	BEGIN { $n_tests += 1 }
d74d639b	284	Hash::Util::FieldHash::_fieldhash \ my( %h), $fieldhash_mode;
1e73acc8	285	bless \ %h, 'abc'; # this bus-errors with a certain bug
	286	ok( 1, "no bus error on bless")
	287	}
	288
	289	BEGIN { plan tests => $n_tests }
	290
	291	#######################################################################
	292
d74d639b	293	sub refaddr {
	294	my $ref = shift;
	295	hex +($ref =~ /\(0x([[:xdigit:]]+)\)$/)[ 0];
	296	}
	297
1e73acc8	298	use Symbol qw( gensym);
	299
	300	BEGIN {
	301	my %gen = (
d74d639b	302	SCALAR => sub { \ my $o },
1e73acc8	303	ARRAY => sub { [] },
	304	HASH => sub { {} },
	305	GLOB => sub { gensym },
	306	CODE => sub { sub {} },
	307	);
	308
	309	sub gen_ref { $gen{ shift()}->() }
	310	}