1#!perl
2use strict; use warnings;
3use Test::More;
4my $n_tests;
5
6use Hash::Util::FieldHash;
7use Scalar::Util 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    BEGIN { $n_tests += 10 }
64}
65
66# magical hash (patches to mg.c and hv.c)
67{
68    # the hook is only sensitive if the set function is NULL
69    my ( %h, $counter);
70    $counter = 123;
71    Hash::Util::FieldHash::_test_uvar_get( \ %h, \ $counter);
72    is( $counter, 0, "got magical hash");
73
74    %h = ( abc => 123);
75    is( $counter, 1, "list assign triggers");
76
77
78    my $x = keys %h;
79    is( $counter, 1, "scalar keys doesn't trigger");
80    is( $x, 1, "there is one key");
81
82    my (@x) = keys %h;
83    is( $counter, 1, "list keys doesn't trigger");
84    is( "@x", "abc", "key is correct");
85
86    $x = values %h;
87    is( $counter, 1, "scalar values doesn't trigger");
88    is( $x, 1, "the value is correct");
89
90    (@x) = values %h;
91    is( $counter, 1, "list values doesn't trigger");
92    is( "@x", "123", "the value is correct");
93
94    $x = each %h;
95    is( $counter, 1, "scalar each doesn't trigger");
96    is( $x, "abc", "the return is correct");
97
98    $x = each %h;
99    is( $counter, 1, "scalar each doesn't trigger");
100    is( $x, undef, "the return is correct");
101
102    (@x) = each %h;
103    is( $counter, 1, "list each doesn't trigger");
104    is( "@x", "abc 123", "the return is correct");
105
106    $x = scalar %h;
107    is( $counter, 1, "hash in scalar context doesn't trigger");
108    is( $x, 1, "correct result");
109
110    (@x) = %h;
111    is( $counter, 1, "hash in list context doesn't trigger");
112    is( "@x", "abc 123", "correct result");
113
114
115    $h{ def} = 456;
116    is( $counter, 2, "lvalue assign triggers");
117
118    (@x) = sort numbers_first %h;
119    is( $counter, 2, "hash in list context doesn't trigger");
120    is( "@x", "123 456 abc def", "correct result");
121
122    exists $h{ def};
123    is( $counter, 3, "good exists triggers");
124
125    exists $h{ xyz};
126    is( $counter, 4, "bad exists triggers");
127
128    delete $h{ def};
129    is( $counter, 5, "good delete triggers");
130
131    (@x) = sort numbers_first %h;
132    is( $counter, 5, "hash in list context doesn't trigger");
133    is( "@x", "123 abc", "correct result");
134
135    delete $h{ xyz};
136    is( $counter, 6, "bad delete triggers");
137
138    (@x) = sort numbers_first %h;
139    is( $counter, 6, "hash in list context doesn't trigger");
140    is( "@x", "123 abc", "correct result");
141
142    $x = $h{ abc};
143    is( $counter, 7, "good read triggers");
144
145    $x = $h{ xyz};
146    is( $counter, 8, "bad read triggers");
147
148    (@x) = sort numbers_first %h;
149    is( $counter, 8, "hash in list context doesn't trigger");
150    is( "@x", "123 abc", "correct result");
151
152
153    bless \ %h;
154    is( $counter, 8, "bless doesn't trigger");
155
156    bless \ %h, 'xyz';
157    is( $counter, 8, "bless doesn't trigger");
158
159    # see that normal set magic doesn't trigger (identity condition)
160    my %i;
161    Hash::Util::FieldHash::_test_uvar_set( \ %i, \ $counter);
162    is( $counter, 0, "got magical hash");
163
164    %i = ( abc => 123);
165    $i{ def} = 456;
166    exists $i{ def};
167    exists $i{ xyz};
168    delete $i{ def};
169    delete $i{ xyz};
170    $x = $i{ abc};
171    $x = $i{ xyz};
172    $x = keys %i;
173    () = keys %i;
174    $x = values %i;
175    () = values %i;
176    $x = each %i;
177    () = each %i;
178
179    is( $counter, 0, "normal set magic never triggers");
180
181    bless \ %i, 'abc';
182    is( $counter, 1, "...except with bless");
183
184    # see that magic with both set and get doesn't trigger
185    $counter = 123;
186    my %j;
187    Hash::Util::FieldHash::_test_uvar_same( \ %j, \ $counter);
188    is( $counter, 0, "got magical hash");
189
190    %j = ( abc => 123);
191    $j{ def} = 456;
192    exists $j{ def};
193    exists $j{ xyz};
194    delete $j{ def};
195    delete $j{ xyz};
196    $x = $j{ abc};
197    $x = $j{ xyz};
198    $x = keys %j;
199    () = keys %j;
200    $x = values %j;
201    () = values %j;
202    $x = each %j;
203    () = each %j;
204
205    is( $counter, 0, "get/set magic never triggers");
206
207    bless \ %j, 'abc';
208    is( $counter, 1, "...except for bless");
209
210    BEGIN { $n_tests += 43 }
211}
212
213BEGIN { plan tests => $n_tests }
214
215