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