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

   1 #!perl
   2 use strict; use warnings;
   3 use Test::More;
   4 my $n_tests = 0;
   5
   6 use Hash::Util::FieldHash qw( :all);
   7 my $ob_reg = Hash::Util::FieldHash::_ob_reg;
   8
   9 #########################
  10
  11 my $fieldhash_mode = 2;
  12
  13 # define ref types to use with some tests
  14 my @test_types;
  15 BEGIN {
  16     # skipping CODE refs, they are differently scoped
  17     @test_types = qw( SCALAR ARRAY HASH GLOB);
  18 }
  19
  20 ### The id() function
  21 {
  22     BEGIN { $n_tests += 4 }
  23     my $ref = [];
  24     is id( $ref), refaddr( $ref), "id is refaddr";
  25     my %h;
  26     Hash::Util::FieldHash::_fieldhash \ %h, $fieldhash_mode;
  27     $h{ $ref} = ();
  28     my ( $key) = keys %h;
  29     is id( $ref), $key, "id is FieldHash key";
  30     my $scalar = 'string';
  31     is id( $scalar), $scalar, "string passes unchanged";
  32     $scalar = 1234;
  33     is id( $scalar), $scalar, "number passes unchanged";
  34 }
  35
  36 ### idhash functionality
  37 {
  38     BEGIN { $n_tests += 3 }
  39     Hash::Util::FieldHash::idhash my %h;
  40     my $ref = sub {};
  41     my $val = 123;
  42     $h{ $ref} = $val;
  43     my ( $key) = keys %h;
  44     is $key, id( $ref), "idhash key correct";
  45     is $h{ $ref}, $val, "value retrieved through ref";
  46     is scalar keys %$ob_reg, 0, "no auto-registry in idhash";
  47 }
  48
  49 ### the register() and id_2obj functions
  50 {
  51     BEGIN { $n_tests += 9 }
  52     my $obj = {};
  53     my $id = id( $obj);
  54     is id_2obj( $id), undef, "unregistered object not retrieved";
  55     is scalar keys %$ob_reg, 0, "object registry empty";
  56     is register( $obj), $obj, "object returned by register";
  57     is scalar keys %$ob_reg, 1, "object registry nonempty";
  58     is id_2obj( $id), $obj, "registered object retrieved";
  59     my %hash;
  60     register( $obj, \ %hash);
  61     $hash{ $id} = 123;
  62     is scalar keys %hash, 1, "key present in registered hash";
  63     undef $obj;
  64     is scalar keys %hash, 0, "key collected from registered hash";
  65     is scalar keys %$ob_reg, 0, "object registry empty again";
  66     eval { register( 1234) };
  67     like $@, qr/^Attempt to register/, "registering non-ref is fatal";
  68
  69 }
  70
  71 ### Object auto-registry
  72
  73 BEGIN { $n_tests += 3 }
  74 {
  75     {
  76         my $obj = {};
  77         {
  78             my $h = {};
  79             Hash::Util::FieldHash::_fieldhash $h, $fieldhash_mode;
  80             $h->{ $obj} = 123;
  81             is( keys %$ob_reg, 1, "one object registered");
  82         }
  83         # field hash stays alive until $obj dies
  84         is( keys %$ob_reg, 1, "object still registered");
  85     }
  86     is( keys %$ob_reg, 0, "object unregistered");
  87 }
  88
  89 ### existence/retrieval/deletion
  90 BEGIN { $n_tests += 6 }
  91 {
  92     no warnings 'misc';
  93     my $val = 123;
  94     Hash::Util::FieldHash::_fieldhash \ my( %h), $fieldhash_mode;
  95     for ( [ str => 'abc'], [ ref => {}] ) {
  96         my ( $keytype, $key) = @$_;
  97         $h{ $key} = $val;
  98         ok( exists $h{ $key},  "existence ($keytype)");
  99         is( $h{ $key}, $val,   "retrieval ($keytype)");
 100         delete $h{ $key};
 101         is( keys %h, 0, "deletion ($keytype)");
 102     }
 103 }
 104
 105 ### id-action (stringification independent of bless)
 106 BEGIN { $n_tests += 5 }
 107 # use Scalar::Util qw( refaddr);
 108 {
 109     my( %f, %g, %h, %i);
 110     Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
 111     Hash::Util::FieldHash::_fieldhash \ %g, $fieldhash_mode;
 112     my $val = 123;
 113     my $key = [];
 114     $f{ $key} = $val;
 115     is( $f{ $key}, $val, "plain key set in field");
 116     my ( $id) = keys %f;
 117     my $refaddr = refaddr($key);
 118     is $id, $refaddr, "key is refaddr";
 119     bless $key;
 120     is( $f{ $key}, $val, "access through blessed");
 121     $key = [];
 122     $h{ $key} = $val;
 123     is( $h{ $key}, $val, "plain key set in hash");
 124     bless $key;
 125     isnt( $h{ $key}, $val, "no access through blessed");
 126 }
 127
 128 # Garbage collection
 129 BEGIN { $n_tests += 1 + 2*( 3*@test_types + 5) + 1 + 2 }
 130
 131 {
 132     my %h;
 133     Hash::Util::FieldHash::_fieldhash \ %h, $fieldhash_mode;
 134     $h{ []} = 123;
 135     is( keys %h, 0, "blip");
 136 }
 137
 138 for my $preload ( [], [ map {}, 1 .. 3] ) {
 139     my $pre = @$preload ? ' (preloaded)' : '';
 140     my %f;
 141     Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
 142     my @preval = map "$_", @$preload;
 143     @f{ @$preload} = @preval;
 144     # Garbage collection separately
 145     for my $type ( @test_types) {
 146         {
 147             my $ref = gen_ref( $type);
 148             $f{ $ref} = $type;
 149             my ( $val) = grep $_ eq $type, values %f;
 150             is( $val, $type, "$type visible$pre");
 151             is(
 152                 keys %$ob_reg,
 153                 1 + @$preload,
 154                 "$type obj registered$pre"
 155             );
 156         }
 157         is( keys %f, @$preload, "$type gone$pre");
 158     }
 159
 160     # Garbage collection collectively
 161     is( keys %$ob_reg, @$preload, "no objs remaining$pre");
 162     {
 163         my @refs = map gen_ref( $_), @test_types;
 164         @f{ @refs} = @test_types;
 165         ok(
 166             eq_set( [ values %f], [ @test_types, @preval]),
 167             "all types present$pre",
 168         );
 169         is(
 170             keys %$ob_reg,
 171             @test_types + @$preload,
 172             "all types registered$pre",
 173         );
 174     }
 175     die "preload gone" unless defined $preload;
 176     ok( eq_set( [ values %f], \ @preval), "all types gone$pre");
 177     is( keys %$ob_reg, @$preload, "all types unregistered$pre");
 178 }
 179 is( keys %$ob_reg, 0, "preload gone after loop");
 180
 181 # autovivified key
 182 {
 183     my %h;
 184     Hash::Util::FieldHash::_fieldhash \ %h, $fieldhash_mode;
 185     my $ref = {};
 186     my $x = $h{ $ref}->[ 0];
 187     is keys %h, 1, "autovivified key present";
 188     undef $ref;
 189     is keys %h, 0, "autovivified key collected";
 190 }
 191
 192 # big key sets
 193 BEGIN { $n_tests += 8 }
 194 {
 195     my $size = 10_000;
 196     my %f;
 197     Hash::Util::FieldHash::_fieldhash \ %f, $fieldhash_mode;
 198     {
 199         my @refs = map [], 1 .. $size;
 200         $f{ $_} = 1 for @refs;
 201         is( keys %f, $size, "many keys singly");
 202         is(
 203             keys %$ob_reg,
 204             $size,
 205             "many objects singly",
 206         );
 207     }
 208     is( keys %f, 0, "many keys singly gone");
 209     is(
 210         keys %$ob_reg,
 211         0,
 212         "many objects singly unregistered",
 213     );
 214
 215     {
 216         my @refs = map [], 1 .. $size;
 217         @f{ @refs } = ( 1) x @refs;
 218         is( keys %f, $size, "many keys at once");
 219         is(
 220             keys %$ob_reg,
 221             $size,
 222             "many objects at once",
 223         );
 224     }
 225     is( keys %f, 0, "many keys at once gone");
 226     is(
 227         keys %$ob_reg,
 228         0,
 229         "many objects at once unregistered",
 230     );
 231 }
 232
 233 # many field hashes
 234 BEGIN { $n_tests += 6 }
 235 {
 236     my $n_fields = 1000;
 237     my @fields = map {}, $n_fields;
 238     Hash::Util::FieldHash::_fieldhash( $_, $fieldhash_mode) for @fields;
 239     my @obs = map gen_ref( $_), @test_types;
 240     my $n_obs = @obs;
 241     for my $field ( @fields ) {
 242         @{ $field }{ @obs} = map ref, @obs;
 243     }
 244     my $err = grep keys %$_ != @obs, @fields;
 245     is( $err, 0, "$n_obs entries in $n_fields fields");
 246     is( keys %$ob_reg, @obs, "$n_obs obs registered");
 247     pop @obs;
 248     $err = grep keys %$_ != @obs, @fields;
 249     is( $err, 0, "one entry gone from $n_fields fields");
 250     is( keys %$ob_reg, @obs, "one ob unregistered");
 251     @obs = ();
 252     $err = grep keys %$_ != @obs, @fields;
 253     is( $err, 0, "all entries gone from $n_fields fields");
 254     is( keys %$ob_reg, @obs, "all obs unregistered");
 255 }
 256
 257
 258 # direct hash assignment
 259 BEGIN { $n_tests += 4 }
 260 {
 261     Hash::Util::FieldHash::_fieldhash( $_, $fieldhash_mode) for \ my( %f, %g, %h);
 262     my $size = 6;
 263     my @obs = map [], 1 .. $size;
 264     @f{ @obs} = ( 1) x $size;
 265     $g{ $_} = $f{ $_} for keys %f; # single assignment
 266     %h = %f;                       # wholesale assignment
 267     @obs = ();
 268     is keys %$ob_reg, 0, "all keys collected";
 269     is keys %f, 0, "orig garbage-collected";
 270     is keys %g, 0, "single-copy garbage-collected";
 271     is keys %h, 0, "wholesale-copy garbage-collected";
 272 }
 273
 274 {
 275     # prototypes in place?
 276     my %proto_tab = (
 277         fieldhash   => '\\%',
 278         fieldhashes => '',
 279         idhash      => '\\%',
 280         idhashes    => '',
 281         id          => '$',
 282         id_2obj     => '$',
 283         register    => '$@',
 284     );
 285
 286
 287     my @notfound = grep !exists $proto_tab{ $_} =>
 288         @Hash::Util::FieldHash::EXPORT_OK;
 289     ok @notfound == 0, "All exports in table";
 290     is prototype( "Hash::Util::FieldHash::$_") || '', $proto_tab{ $_},
 291         "$_ has prototype ($proto_tab{ $_})" for
 292             @Hash::Util::FieldHash::EXPORT_OK;
 293
 294     BEGIN { $n_tests += 1 + @Hash::Util::FieldHash::EXPORT_OK }
 295 }
 296
 297 {
 298     BEGIN { $n_tests += 1 }
 299     Hash::Util::FieldHash::_fieldhash \ my( %h), $fieldhash_mode;
 300     bless \ %h, 'abc'; # this bus-errors with a certain bug
 301     ok( 1, "no bus error on bless")
 302 }
 303
 304 BEGIN { plan tests => $n_tests }
 305
 306 #######################################################################
 307
 308 sub refaddr {
 309     # silence possible warnings from hex() on 64bit systems
 310     no warnings 'portable';
 311
 312     my $ref = shift;
 313     hex +($ref =~ /\(0x([[:xdigit:]]+)\)$/)[ 0];
 314 }
 315
 316 use Symbol qw( gensym);
 317
 318 BEGIN {
 319     my %gen = (
 320         SCALAR => sub { \ my $o },
 321         ARRAY  => sub { [] },
 322         HASH   => sub { {} },
 323         GLOB   => sub { gensym },
 324         CODE   => sub { sub {} },
 325     );
 326
 327     sub gen_ref { $gen{ shift()}->() }
 328 }