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 my $ob_reg = Hash::Util::FieldHash::_ob_reg;
  16
  17 #########################
  18
  19 my $fieldhash_mode = 2;
  20
  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
  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
  80
  81 BEGIN { $n_tests += 3 }
  82 {
  83     {
  84         my $obj = {};
  85         {
  86             my $h = {};
  87             Hash::Util::FieldHash::_fieldhash $h, $fieldhash_mode;
  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;
 102     Hash::Util::FieldHash::_fieldhash \ my( %h), $fieldhash_mode;
 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)
 114 BEGIN { $n_tests += 5 }
 115 # use Scalar::Util qw( refaddr);
 116 {
 117     my( %f, %g, %h, %i);
 118     Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
 119     Hash::Util::FieldHash::_fieldhash \ %g, $fieldhash_mode;
 120     my $val = 123;
 121     my $key = [];
 122     $f{ $key} = $val;
 123     is( $f{ $key}, $val, "plain key set in field");
 124     my ( $id) = keys %f;
 125     my $refaddr = hex +($key =~ /\(0x([[:xdigit:]]+)\)$/)[ 0];
 126     is $id, $refaddr, "key is refaddr";
 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
 137 BEGIN { $n_tests += 1 + 2*( 3*@test_types + 5) + 1 + 2 }
 138
 139 {
 140     my %h;
 141     Hash::Util::FieldHash::_fieldhash \ %h, $fieldhash_mode;
 142     $h{ []} = 123;
 143     is( keys %h, 0, "blip");
 144 }
 145
 146 for my $preload ( [], [ map {}, 1 .. 3] ) {
 147     my $pre = @$preload ? ' (preloaded)' : '';
 148     my %f;
 149     Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
 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(
 160                 keys %$ob_reg,
 161                 1 + @$preload,
 162                 "$type obj registered$pre"
 163             );
 164         }
 165         is( keys %f, @$preload, "$type gone$pre");
 166     }
 167
 168     # Garbage collection collectively
 169     is( keys %$ob_reg, @$preload, "no objs remaining$pre");
 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(
 178             keys %$ob_reg,
 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");
 185     is( keys %$ob_reg, @$preload, "all types unregistered$pre");
 186 }
 187 is( keys %$ob_reg, 0, "preload gone after loop");
 188
 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
 200 # big key sets
 201 BEGIN { $n_tests += 8 }
 202 {
 203     my $size = 10_000;
 204     my %f;
 205     Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
 206     {
 207         my @refs = map [], 1 .. $size;
 208         $f{ $_} = 1 for @refs;
 209         is( keys %f, $size, "many keys singly");
 210         is(
 211             keys %$ob_reg,
 212             $size,
 213             "many objects singly",
 214         );
 215     }
 216     is( keys %f, 0, "many keys singly gone");
 217     is(
 218         keys %$ob_reg,
 219         0,
 220         "many objects singly unregistered",
 221     );
 222
 223     {
 224         my @refs = map [], 1 .. $size;
 225         @f{ @refs } = ( 1) x @refs;
 226         is( keys %f, $size, "many keys at once");
 227         is(
 228             keys %$ob_reg,
 229             $size,
 230             "many objects at once",
 231         );
 232     }
 233     is( keys %f, 0, "many keys at once gone");
 234     is(
 235         keys %$ob_reg,
 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;
 245     my @fields = map {}, $n_fields;
 246     Hash::Util::FieldHash::_fieldhash( $_, $fieldhash_mode) for @fields;
 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");
 254     is( keys %$ob_reg, @obs, "$n_obs obs registered");
 255     pop @obs;
 256     $err = grep keys %$_ != @obs, @fields;
 257     is( $err, 0, "one entry gone from $n_fields fields");
 258     is( keys %$ob_reg, @obs, "one ob unregistered");
 259     @obs = ();
 260     $err = grep keys %$_ != @obs, @fields;
 261     is( $err, 0, "all entries gone from $n_fields fields");
 262     is( keys %$ob_reg, @obs, "all obs unregistered");
 263 }
 264
 265
 266 # direct hash assignment
 267 BEGIN { $n_tests += 4 }
 268 {
 269     Hash::Util::FieldHash::_fieldhash( $_, $fieldhash_mode) for \ my( %f, %g, %h);
 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";
 278     is keys %g, 0, "single-copy garbage-collected";
 279     is keys %h, 0, "wholesale-copy garbage-collected";
 280 }
 281
 282 {
 283     BEGIN { $n_tests += 1 }
 284     Hash::Util::FieldHash::_fieldhash \ my( %h), $fieldhash_mode;
 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
 293 sub refaddr {
 294     my $ref = shift;
 295     hex +($ref =~ /\(0x([[:xdigit:]]+)\)$/)[ 0];
 296 }
 297
 298 use Symbol qw( gensym);
 299
 300 BEGIN {
 301     my %gen = (
 302         SCALAR => sub { \ my $o },
 303         ARRAY  => sub { [] },
 304         HASH   => sub { {} },
 305         GLOB   => sub { gensym },
 306         CODE   => sub { sub {} },
 307     );
 308
 309     sub gen_ref { $gen{ shift()}->() }
 310 }