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