This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
8ffbae6f685e744900b61f2de1d8885bf7475455
[perl5.git] / 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 # define ref types to use with some tests
20 my @test_types;
21 BEGIN {
22     # skipping CODE refs, they are differently scoped
23     @test_types = qw( SCALAR ARRAY HASH GLOB);
24 }
25
26 ### Object registry
27
28 BEGIN { $n_tests += 3 }
29 {
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 %$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 %$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 %$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 %$ob_reg, @$preload, "all types unregistered$pre");
127 }
128 is( keys %$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 %$ob_reg,
141             $size,
142             "many objects singly",
143         );
144     }
145     is( keys %f, 0, "many keys singly gone");
146     is(
147         keys %$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 %$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 %$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 %$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 %$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 %$ob_reg, @obs, "all obs unregistered");
191 }
192
193
194 # direct hash assignment
195 BEGIN { $n_tests += 4 }
196 {
197     fieldhashes \ my( %f, %g, %h);
198     my $size = 6;
199     my @obs = map [], 1 .. $size;
200     @f{ @obs} = ( 1) x $size;
201     $g{ $_} = $f{ $_} for keys %f; # single assignment
202     %h = %f;                       # wholesale assignment
203     @obs = ();
204     is keys %$ob_reg, 0, "all keys collected";
205     is keys %f, 0, "orig garbage-collected";
206     is keys %g, 0, "single-copy garbage-collected";
207     is keys %h, 0, "wholesale-copy garbage-collected";
208 }
209
210 {
211
212     BEGIN { $n_tests += 1 }
213     fieldhash my %h;
214     bless \ %h, 'abc'; # this bus-errors with a certain bug
215     ok( 1, "no bus error on bless")
216 }
217
218 BEGIN { plan tests => $n_tests }
219
220 #######################################################################
221
222 use Symbol qw( gensym);
223
224 BEGIN {
225     my %gen = (
226         SCALAR => sub { \ my $x },
227         ARRAY  => sub { [] },
228         HASH   => sub { {} },
229         GLOB   => sub { gensym },
230         CODE   => sub { sub {} },
231     );
232
233     sub gen_ref { $gen{ shift()}->() }
234 }