ext/Hash/Util/FieldHash/t/02_function.t

   1 #!perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 use strict; use warnings;
   9 use Test::More;
  10 my $n_tests = 0;
  11
  12 use Hash::Util::FieldHash qw( :all);
  13
  14 #########################
  15
  16 # define ref types to use with some tests
  17 my @test_types;
  18 BEGIN {
  19     # skipping CODE refs, they are differently scoped
  20     @test_types = qw( SCALAR ARRAY HASH GLOB);
  21 }
  22
  23 ### Object registry
  24
  25 BEGIN { $n_tests += 3 }
  26 {
  27     my $ob_reg = \ %Hash::Util::FieldHash::ob_reg;
  28     {
  29         my $obj = {};
  30         {
  31             my $h;
  32             fieldhash %$h;
  33             $h->{ $obj} = 123;
  34             is( keys %$ob_reg, 1, "one object registered");
  35         }
  36         # field hash stays alive until $obj dies
  37         is( keys %$ob_reg, 1, "object still registered");
  38     }
  39     is( keys %$ob_reg, 0, "object unregistered");
  40 }
  41
  42 ### existence/retrieval/deletion
  43 BEGIN { $n_tests += 6 }
  44 {
  45     no warnings 'misc';
  46     my $val = 123;
  47     fieldhash my %h;
  48     for ( [ str => 'abc'], [ ref => {}] ) {
  49         my ( $keytype, $key) = @$_;
  50         $h{ $key} = $val;
  51         ok( exists $h{ $key},  "existence ($keytype)");
  52         is( $h{ $key}, $val,   "retrieval ($keytype)");
  53         delete $h{ $key};
  54         is( keys %h, 0, "deletion ($keytype)");
  55     }
  56 }
  57
  58 ### id-action (stringification independent of bless)
  59 BEGIN { $n_tests += 4 }
  60 {
  61     my( %f, %g, %h, %i);
  62     fieldhash %f;
  63     fieldhash %g;
  64     my $val = 123;
  65     my $key = [];
  66     $f{ $key} = $val;
  67     is( $f{ $key}, $val, "plain key set in field");
  68     bless $key;
  69     is( $f{ $key}, $val, "access through blessed");
  70     $key = [];
  71     $h{ $key} = $val;
  72     is( $h{ $key}, $val, "plain key set in hash");
  73     bless $key;
  74     isnt( $h{ $key}, $val, "no access through blessed");
  75 }
  76
  77 # Garbage collection
  78 BEGIN { $n_tests += 1 + 2*( 3*@test_types + 5) + 1 }
  79
  80 {
  81     fieldhash my %h;
  82     $h{ []} = 123;
  83     is( keys %h, 0, "blip");
  84 }
  85
  86 for my $preload ( [], [ map {}, 1 .. 3] ) {
  87     my $pre = @$preload ? ' (preloaded)' : '';
  88     fieldhash my %f;
  89     my @preval = map "$_", @$preload;
  90     @f{ @$preload} = @preval;
  91     # Garbage collection separately
  92     for my $type ( @test_types) {
  93         {
  94             my $ref = gen_ref( $type);
  95             $f{ $ref} = $type;
  96             my ( $val) = grep $_ eq $type, values %f;
  97             is( $val, $type, "$type visible$pre");
  98             is(
  99                 keys %Hash::Util::FieldHash::ob_reg,
 100                 1 + @$preload,
 101                 "$type obj registered$pre"
 102             );
 103         }
 104         is( keys %f, @$preload, "$type gone$pre");
 105     }
 106
 107     # Garbage collection collectively
 108     is( keys %Hash::Util::FieldHash::ob_reg, @$preload, "no objs remaining$pre");
 109     {
 110         my @refs = map gen_ref( $_), @test_types;
 111         @f{ @refs} = @test_types;
 112         ok(
 113             eq_set( [ values %f], [ @test_types, @preval]),
 114             "all types present$pre",
 115         );
 116         is(
 117             keys %Hash::Util::FieldHash::ob_reg,
 118             @test_types + @$preload,
 119             "all types registered$pre",
 120         );
 121     }
 122     die "preload gone" unless defined $preload;
 123     ok( eq_set( [ values %f], \ @preval), "all types gone$pre");
 124     is( keys %Hash::Util::FieldHash::ob_reg, @$preload, "all types unregistered$pre");
 125 }
 126 is( keys %Hash::Util::FieldHash::ob_reg, 0, "preload gone after loop");
 127
 128 # big key sets
 129 BEGIN { $n_tests += 8 }
 130 {
 131     my $size = 10_000;
 132     fieldhash( my %f);
 133     {
 134         my @refs = map [], 1 .. $size;
 135         $f{ $_} = 1 for @refs;
 136         is( keys %f, $size, "many keys singly");
 137         is(
 138             keys %Hash::Util::FieldHash::ob_reg,
 139             $size,
 140             "many objects singly",
 141         );
 142     }
 143     is( keys %f, 0, "many keys singly gone");
 144     is(
 145         keys %Hash::Util::FieldHash::ob_reg,
 146         0,
 147         "many objects singly unregistered",
 148     );
 149
 150     {
 151         my @refs = map [], 1 .. $size;
 152         $f{ $_} = 1 for @refs;
 153         is( keys %f, $size, "many keys at once");
 154         is(
 155             keys %Hash::Util::FieldHash::ob_reg,
 156             $size,
 157             "many objects at once",
 158         );
 159     }
 160     is( keys %f, 0, "many keys at once gone");
 161     is(
 162         keys %Hash::Util::FieldHash::ob_reg,
 163         0,
 164         "many objects at once unregistered",
 165     );
 166 }
 167
 168 # many field hashes
 169 BEGIN { $n_tests += 6 }
 170 {
 171     my $n_fields = 1000;
 172     my @fields = map &fieldhash( {}), 1 .. $n_fields;
 173     my @obs = map gen_ref( $_), @test_types;
 174     my $n_obs = @obs;
 175     for my $field ( @fields ) {
 176         @{ $field }{ @obs} = map ref, @obs;
 177     }
 178     my $err = grep keys %$_ != @obs, @fields;
 179     is( $err, 0, "$n_obs entries in $n_fields fields");
 180     is( keys %Hash::Util::FieldHash::ob_reg, @obs, "$n_obs obs registered");
 181     pop @obs;
 182     $err = grep keys %$_ != @obs, @fields;
 183     is( $err, 0, "one entry gone from $n_fields fields");
 184     is( keys %Hash::Util::FieldHash::ob_reg, @obs, "one ob unregistered");
 185     @obs = ();
 186     $err = grep keys %$_ != @obs, @fields;
 187     is( $err, 0, "all entries gone from $n_fields fields");
 188     is( keys %Hash::Util::FieldHash::ob_reg, @obs, "all obs unregistered");
 189 }
 190
 191 {
 192
 193     BEGIN { $n_tests += 1 }
 194     fieldhash my %h;
 195     bless \ %h, 'abc'; # this bus-errors with a certain bug
 196     ok( 1, "no bus error on bless")
 197 }
 198
 199 BEGIN { plan tests => $n_tests }
 200
 201 #######################################################################
 202
 203 use Symbol qw( gensym);
 204
 205 BEGIN {
 206     my %gen = (
 207         SCALAR => sub { \ my $x },
 208         ARRAY  => sub { [] },
 209         HASH   => sub { {} },
 210         GLOB   => sub { gensym },
 211         CODE   => sub { sub {} },
 212     );
 213
 214     sub gen_ref { $gen{ shift()}->() }
 215 }