xref: /openbsd-src/gnu/usr.bin/perl/ext/Hash-Util-FieldHash/t/05_perlhook.t (revision 91f110e064cd7c194e59e019b83bb7496c1c84d4) 
1#!perl
2use strict; use warnings;
3use Test::More;
4my $n_tests;
5
6use Hash::Util::FieldHash;
7use Scalar::Util qw( weaken);
8
9# The functions in Hash::Util::FieldHash
10# _test_uvar_get, _test_uvar_get and _test_uvar_both
11
12# _test_uvar_get( $anyref, \ $counter) makes the referent of $anyref
13# "uvar"-magical with get magic only.  $counter is reset if the magic
14# could be established.  $counter will be incremented each time the
15# magic "get" function is called.
16
17# _test_uvar_set does the same for "set" magic.  _test_uvar_both
18# sets both magic functions identically.  Both use the same counter.
19
20# magical weak ref (patch to sv.c)
21{
22    my( $magref, $counter);
23
24    $counter = 123;
25    Hash::Util::FieldHash::_test_uvar_set( \ $magref, \ $counter);
26    is( $counter, 0, "got magical scalar");
27
28    my $ref = [];
29    $magref = $ref;
30    is( $counter, 1, "store triggers magic");
31
32    weaken $magref;
33    is( $counter, 1, "weaken doesn't trigger magic");
34
35    { my $x = $magref }
36    is( $counter, 1, "read doesn't trigger magic");
37
38    undef $ref;
39    is( $counter, 2, "ref expiry triggers magic (weakref patch worked)");
40
41    is( $magref, undef, "weak ref works normally");
42
43    # same, but overwrite weakref before expiry
44    $counter = 0;
45    weaken( $magref = $ref = []);
46    is( $counter, 1, "setup for overwrite");
47
48    $magref = my $other_ref = [];
49    is( $counter, 2, "overwrite triggers");
50
51    undef $ref;
52    is( $counter, 2, "ref expiry doesn't trigger after overwrite");
53
54    is( $magref, $other_ref, "weak ref doesn't kill overwritten value");
55
56    BEGIN { $n_tests += 10 }
57}
58
59# magical hash (patches to mg.c and hv.c)
60{
61    # the hook is only sensitive if the set function is NULL
62    my ( %h, $counter);
63    $counter = 123;
64    Hash::Util::FieldHash::_test_uvar_get( \ %h, \ $counter);
65    is( $counter, 0, "got magical hash");
66
67    %h = ( abc => 123);
68    is( $counter, 1, "list assign triggers");
69
70
71    my $x = keys %h;
72    is( $counter, 1, "scalar keys doesn't trigger");
73    is( $x, 1, "there is one key");
74
75    my (@x) = keys %h;
76    is( $counter, 1, "list keys doesn't trigger");
77    is( "@x", "abc", "key is correct");
78
79    $x = values %h;
80    is( $counter, 1, "scalar values doesn't trigger");
81    is( $x, 1, "the value is correct");
82
83    (@x) = values %h;
84    is( $counter, 1, "list values doesn't trigger");
85    is( "@x", "123", "the value is correct");
86
87    $x = each %h;
88    is( $counter, 1, "scalar each doesn't trigger");
89    is( $x, "abc", "the return is correct");
90
91    $x = each %h;
92    is( $counter, 1, "scalar each doesn't trigger");
93    is( $x, undef, "the return is correct");
94
95    (@x) = each %h;
96    is( $counter, 1, "list each doesn't trigger");
97    is( "@x", "abc 123", "the return is correct");
98
99    $x = %h;
100    is( $counter, 1, "hash in scalar context doesn't trigger");
101    like( $x, qr!^\d+/\d+$!, "correct result");
102
103    (@x) = %h;
104    is( $counter, 1, "hash in list context doesn't trigger");
105    is( "@x", "abc 123", "correct result");
106
107
108    $h{ def} = 456;
109    is( $counter, 2, "lvalue assign triggers");
110
111    (@x) = sort %h;
112    is( $counter, 2, "hash in list context doesn't trigger");
113    is( "@x", "123 456 abc def", "correct result");
114
115    exists $h{ def};
116    is( $counter, 3, "good exists triggers");
117
118    exists $h{ xyz};
119    is( $counter, 4, "bad exists triggers");
120
121    delete $h{ def};
122    is( $counter, 5, "good delete triggers");
123
124    (@x) = sort %h;
125    is( $counter, 5, "hash in list context doesn't trigger");
126    is( "@x", "123 abc", "correct result");
127
128    delete $h{ xyz};
129    is( $counter, 6, "bad delete triggers");
130
131    (@x) = sort %h;
132    is( $counter, 6, "hash in list context doesn't trigger");
133    is( "@x", "123 abc", "correct result");
134
135    $x = $h{ abc};
136    is( $counter, 7, "good read triggers");
137
138    $x = $h{ xyz};
139    is( $counter, 8, "bad read triggers");
140
141    (@x) = sort %h;
142    is( $counter, 8, "hash in list context doesn't trigger");
143    is( "@x", "123 abc", "correct result");
144
145
146    bless \ %h;
147    is( $counter, 8, "bless doesn't trigger");
148
149    bless \ %h, 'xyz';
150    is( $counter, 8, "bless doesn't trigger");
151
152    # see that normal set magic doesn't trigger (identity condition)
153    my %i;
154    Hash::Util::FieldHash::_test_uvar_set( \ %i, \ $counter);
155    is( $counter, 0, "got magical hash");
156
157    %i = ( abc => 123);
158    $i{ def} = 456;
159    exists $i{ def};
160    exists $i{ xyz};
161    delete $i{ def};
162    delete $i{ xyz};
163    $x = $i{ abc};
164    $x = $i{ xyz};
165    $x = keys %i;
166    () = keys %i;
167    $x = values %i;
168    () = values %i;
169    $x = each %i;
170    () = each %i;
171
172    is( $counter, 0, "normal set magic never triggers");
173
174    bless \ %i, 'abc';
175    is( $counter, 1, "...except with bless");
176
177    # see that magic with both set and get doesn't trigger
178    $counter = 123;
179    my %j;
180    Hash::Util::FieldHash::_test_uvar_same( \ %j, \ $counter);
181    is( $counter, 0, "got magical hash");
182
183    %j = ( abc => 123);
184    $j{ def} = 456;
185    exists $j{ def};
186    exists $j{ xyz};
187    delete $j{ def};
188    delete $j{ xyz};
189    $x = $j{ abc};
190    $x = $j{ xyz};
191    $x = keys %j;
192    () = keys %j;
193    $x = values %j;
194    () = values %j;
195    $x = each %j;
196    () = each %j;
197
198    is( $counter, 0, "get/set magic never triggers");
199
200    bless \ %j, 'abc';
201    is( $counter, 1, "...except for bless");
202
203    BEGIN { $n_tests += 43 }
204}
205
206BEGIN { plan tests => $n_tests }
207
208