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

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