Commit | Line | Data |
677fb045 |
1 | #!./perl -w |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
6 | require './test.pl'; |
7 | } |
8 | |
9 | # use strict; |
10 | |
e3791f55 |
11 | plan tests => 215; |
677fb045 |
12 | |
13 | my @comma = ("key", "value"); |
14 | |
15 | # The peephole optimiser already knows that it should convert the string in |
16 | # $foo{string} into a shared hash key scalar. It might be worth making the |
17 | # tokeniser build the LHS of => as a shared hash key scalar too. |
18 | # And so there's the possiblility of it going wrong |
19 | # And going right on 8 bit but wrong on utf8 keys. |
20 | # And really we should also try utf8 literals in {} and => in utf8.t |
21 | |
22 | # Some of these tests are (effectively) duplicated in each.t |
23 | my %comma = @comma; |
24 | ok (keys %comma == 1, 'keys on comma hash'); |
25 | ok (values %comma == 1, 'values on comma hash'); |
26 | # defeat any tokeniser or optimiser cunning |
27 | my $key = 'ey'; |
28 | is ($comma{"k" . $key}, "value", 'is key present? (unoptimised)'); |
29 | # now with cunning: |
30 | is ($comma{key}, "value", 'is key present? (maybe optimised)'); |
31 | #tokeniser may treat => differently. |
32 | my @temp = (key=>undef); |
33 | is ($comma{$temp[0]}, "value", 'is key present? (using LHS of =>)'); |
34 | |
35 | @temp = %comma; |
36 | ok (eq_array (\@comma, \@temp), 'list from comma hash'); |
37 | |
38 | @temp = each %comma; |
39 | ok (eq_array (\@comma, \@temp), 'first each from comma hash'); |
40 | @temp = each %comma; |
41 | ok (eq_array ([], \@temp), 'last each from comma hash'); |
42 | |
43 | my %temp = %comma; |
44 | |
45 | ok (keys %temp == 1, 'keys on copy of comma hash'); |
46 | ok (values %temp == 1, 'values on copy of comma hash'); |
47 | is ($temp{'k' . $key}, "value", 'is key present? (unoptimised)'); |
48 | # now with cunning: |
49 | is ($temp{key}, "value", 'is key present? (maybe optimised)'); |
50 | @temp = (key=>undef); |
51 | is ($comma{$temp[0]}, "value", 'is key present? (using LHS of =>)'); |
52 | |
53 | @temp = %temp; |
54 | ok (eq_array (\@temp, \@temp), 'list from copy of comma hash'); |
55 | |
56 | @temp = each %temp; |
57 | ok (eq_array (\@temp, \@temp), 'first each from copy of comma hash'); |
58 | @temp = each %temp; |
59 | ok (eq_array ([], \@temp), 'last each from copy of comma hash'); |
60 | |
61 | my @arrow = (Key =>"Value"); |
62 | |
63 | my %arrow = @arrow; |
64 | ok (keys %arrow == 1, 'keys on arrow hash'); |
65 | ok (values %arrow == 1, 'values on arrow hash'); |
66 | # defeat any tokeniser or optimiser cunning |
67 | $key = 'ey'; |
68 | is ($arrow{"K" . $key}, "Value", 'is key present? (unoptimised)'); |
69 | # now with cunning: |
70 | is ($arrow{Key}, "Value", 'is key present? (maybe optimised)'); |
71 | #tokeniser may treat => differently. |
72 | @temp = ('Key', undef); |
73 | is ($arrow{$temp[0]}, "Value", 'is key present? (using LHS of =>)'); |
74 | |
75 | @temp = %arrow; |
76 | ok (eq_array (\@arrow, \@temp), 'list from arrow hash'); |
77 | |
78 | @temp = each %arrow; |
79 | ok (eq_array (\@arrow, \@temp), 'first each from arrow hash'); |
80 | @temp = each %arrow; |
81 | ok (eq_array ([], \@temp), 'last each from arrow hash'); |
82 | |
83 | %temp = %arrow; |
84 | |
85 | ok (keys %temp == 1, 'keys on copy of arrow hash'); |
86 | ok (values %temp == 1, 'values on copy of arrow hash'); |
87 | is ($temp{'K' . $key}, "Value", 'is key present? (unoptimised)'); |
88 | # now with cunning: |
89 | is ($temp{Key}, "Value", 'is key present? (maybe optimised)'); |
90 | @temp = ('Key', undef); |
91 | is ($arrow{$temp[0]}, "Value", 'is key present? (using LHS of =>)'); |
92 | |
93 | @temp = %temp; |
94 | ok (eq_array (\@temp, \@temp), 'list from copy of arrow hash'); |
95 | |
96 | @temp = each %temp; |
97 | ok (eq_array (\@temp, \@temp), 'first each from copy of arrow hash'); |
98 | @temp = each %temp; |
99 | ok (eq_array ([], \@temp), 'last each from copy of arrow hash'); |
100 | |
101 | my %direct = ('Camel', 2, 'Dromedary', 1); |
102 | my %slow; |
103 | $slow{Dromedary} = 1; |
104 | $slow{Camel} = 2; |
105 | |
106 | ok (eq_hash (\%slow, \%direct), "direct list assignment to hash"); |
107 | %direct = (Camel => 2, 'Dromedary' => 1); |
108 | ok (eq_hash (\%slow, \%direct), "direct list assignment to hash using =>"); |
109 | |
110 | $slow{Llama} = 0; # A llama is not a camel :-) |
111 | ok (!eq_hash (\%direct, \%slow), "different hashes should not be equal!"); |
112 | |
113 | my (%names, %names_copy); |
114 | %names = ('$' => 'Scalar', '@' => 'Array', # Grr ' |
115 | '%', 'Hash', '&', 'Code'); |
116 | %names_copy = %names; |
117 | ok (eq_hash (\%names, \%names_copy), "check we can copy our hash"); |
118 | |
119 | sub in { |
120 | my %args = @_; |
121 | return eq_hash (\%names, \%args); |
122 | } |
123 | |
124 | ok (in (%names), "pass hash into a method"); |
125 | |
126 | sub in_method { |
127 | my $self = shift; |
128 | my %args = @_; |
129 | return eq_hash (\%names, \%args); |
130 | } |
131 | |
132 | ok (main->in_method (%names), "pass hash into a method"); |
133 | |
134 | sub out { |
135 | return %names; |
136 | } |
137 | %names_copy = out (); |
138 | |
139 | ok (eq_hash (\%names, \%names_copy), "pass hash from a subroutine"); |
140 | |
141 | sub out_method { |
142 | my $self = shift; |
143 | return %names; |
144 | } |
145 | %names_copy = main->out_method (); |
146 | |
147 | ok (eq_hash (\%names, \%names_copy), "pass hash from a method"); |
148 | |
149 | sub in_out { |
150 | my %args = @_; |
151 | return %args; |
152 | } |
153 | %names_copy = in_out (%names); |
154 | |
155 | ok (eq_hash (\%names, \%names_copy), "pass hash to and from a subroutine"); |
156 | |
157 | sub in_out_method { |
158 | my $self = shift; |
159 | my %args = @_; |
160 | return %args; |
161 | } |
162 | %names_copy = main->in_out_method (%names); |
163 | |
164 | ok (eq_hash (\%names, \%names_copy), "pass hash to and from a method"); |
165 | |
166 | my %names_copy2 = %names; |
167 | ok (eq_hash (\%names, \%names_copy2), "check copy worked"); |
168 | |
169 | # This should get ignored. |
170 | %names_copy = ('%', 'Associative Array', %names); |
171 | |
172 | ok (eq_hash (\%names, \%names_copy), "duplicates at the start of a list"); |
173 | |
174 | # This should not |
175 | %names_copy = ('*', 'Typeglob', %names); |
176 | |
177 | $names_copy2{'*'} = 'Typeglob'; |
178 | ok (eq_hash (\%names_copy, \%names_copy2), "duplicates at the end of a list"); |
179 | |
180 | %names_copy = ('%', 'Associative Array', '*', 'Endangered species', %names, |
181 | '*', 'Typeglob',); |
182 | |
183 | ok (eq_hash (\%names_copy, \%names_copy2), "duplicates at both ends"); |
184 | |
185 | # And now UTF8 |
186 | |
187 | foreach my $chr (60, 200, 600, 6000, 60000) { |
188 | # This little game may set a UTF8 flag internally. Or it may not. :-) |
189 | my ($key, $value) = (chr ($chr) . "\x{ABCD}", "$chr\x{ABCD}"); |
190 | chop ($key, $value); |
191 | my @utf8c = ($key, $value); |
192 | my %utf8c = @utf8c; |
193 | |
194 | ok (keys %utf8c == 1, 'keys on utf8 comma hash'); |
195 | ok (values %utf8c == 1, 'values on utf8 comma hash'); |
196 | # defeat any tokeniser or optimiser cunning |
197 | is ($utf8c{"" . $key}, $value, 'is key present? (unoptimised)'); |
198 | my $tempval = sprintf '$utf8c{"\x{%x}"}', $chr; |
199 | is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)"); |
200 | $tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr; |
201 | eval $tempval or die "'$tempval' gave $@"; |
202 | is ($utf8c{$temp[0]}, $value, 'is key present? (using LHS of $tempval)'); |
203 | |
204 | @temp = %utf8c; |
205 | ok (eq_array (\@utf8c, \@temp), 'list from utf8 comma hash'); |
206 | |
207 | @temp = each %utf8c; |
208 | ok (eq_array (\@utf8c, \@temp), 'first each from utf8 comma hash'); |
209 | @temp = each %utf8c; |
210 | ok (eq_array ([], \@temp), 'last each from utf8 comma hash'); |
211 | |
212 | %temp = %utf8c; |
213 | |
214 | ok (keys %temp == 1, 'keys on copy of utf8 comma hash'); |
215 | ok (values %temp == 1, 'values on copy of utf8 comma hash'); |
216 | is ($temp{"" . $key}, $value, 'is key present? (unoptimised)'); |
217 | $tempval = sprintf '$temp{"\x{%x}"}', $chr; |
218 | is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)"); |
219 | $tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr; |
220 | eval $tempval or die "'$tempval' gave $@"; |
221 | is ($temp{$temp[0]}, $value, "is key present? (using LHS of $tempval)"); |
222 | |
223 | @temp = %temp; |
224 | ok (eq_array (\@temp, \@temp), 'list from copy of utf8 comma hash'); |
225 | |
226 | @temp = each %temp; |
227 | ok (eq_array (\@temp, \@temp), 'first each from copy of utf8 comma hash'); |
228 | @temp = each %temp; |
229 | ok (eq_array ([], \@temp), 'last each from copy of utf8 comma hash'); |
230 | |
231 | my $assign = sprintf '("\x{%x}" => "%d")', $chr, $chr; |
232 | print "# $assign\n"; |
233 | my (@utf8a) = eval $assign; |
234 | |
235 | my %utf8a = @utf8a; |
236 | ok (keys %utf8a == 1, 'keys on utf8 arrow hash'); |
237 | ok (values %utf8a == 1, 'values on utf8 arrow hash'); |
238 | # defeat any tokeniser or optimiser cunning |
239 | is ($utf8a{$key . ""}, $value, 'is key present? (unoptimised)'); |
240 | $tempval = sprintf '$utf8a{"\x{%x}"}', $chr; |
241 | is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)"); |
242 | $tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr; |
243 | eval $tempval or die "'$tempval' gave $@"; |
244 | is ($utf8a{$temp[0]}, $value, "is key present? (using LHS of $tempval)"); |
245 | |
246 | @temp = %utf8a; |
247 | ok (eq_array (\@utf8a, \@temp), 'list from utf8 arrow hash'); |
248 | |
249 | @temp = each %utf8a; |
250 | ok (eq_array (\@utf8a, \@temp), 'first each from utf8 arrow hash'); |
251 | @temp = each %utf8a; |
252 | ok (eq_array ([], \@temp), 'last each from utf8 arrow hash'); |
253 | |
254 | %temp = %utf8a; |
255 | |
256 | ok (keys %temp == 1, 'keys on copy of utf8 arrow hash'); |
257 | ok (values %temp == 1, 'values on copy of utf8 arrow hash'); |
258 | is ($temp{'' . $key}, $value, 'is key present? (unoptimised)'); |
259 | $tempval = sprintf '$temp{"\x{%x}"}', $chr; |
260 | is (eval $tempval, $value, "is key present? (maybe $tempval is optimised)"); |
261 | $tempval = sprintf '@temp = ("\x{%x}" => undef)', $chr; |
262 | eval $tempval or die "'$tempval' gave $@"; |
263 | is ($temp{$temp[0]}, $value, "is key present? (using LHS of $tempval)"); |
264 | |
265 | @temp = %temp; |
266 | ok (eq_array (\@temp, \@temp), 'list from copy of utf8 arrow hash'); |
267 | |
268 | @temp = each %temp; |
269 | ok (eq_array (\@temp, \@temp), 'first each from copy of utf8 arrow hash'); |
270 | @temp = each %temp; |
271 | ok (eq_array ([], \@temp), 'last each from copy of utf8 arrow hash'); |
272 | |
273 | } |
274 | |
ca65944e |
275 | # now some tests for hash assignment in scalar and list context with |
276 | # duplicate keys [perl #24380] |
277 | { |
278 | my %h; my $x; my $ar; |
279 | is( (join ':', %h = (1) x 8), '1:1', |
280 | 'hash assignment in list context removes duplicates' ); |
281 | is( scalar( %h = (1,2,1,3,1,4,1,5) ), 2, |
282 | 'hash assignment in scalar context' ); |
283 | is( scalar( ($x,%h) = (0,1,2,1,3,1,4,1,5) ), 3, |
284 | 'scalar + hash assignment in scalar context' ); |
285 | $ar = [ %h = (1,2,1,3,1,4,1,5) ]; |
286 | is( $#$ar, 1, 'hash assignment in list context' ); |
287 | is( "@$ar", "1 5", '...gets the last values' ); |
288 | $ar = [ ($x,%h) = (0,1,2,1,3,1,4,1,5) ]; |
289 | is( $#$ar, 2, 'scalar + hash assignment in list context' ); |
290 | is( "@$ar", "0 1 5", '...gets the last values' ); |
291 | } |
e3791f55 |
292 | |
293 | # test stringification of keys |
294 | { |
295 | no warnings 'once'; |
296 | my @types = qw( SCALAR ARRAY HASH CODE GLOB); |
297 | my @refs = ( \ do { my $x }, [], {}, sub {}, \ *x); |
298 | my(%h, %expect); |
299 | @h{@refs} = @types; |
300 | @expect{map "$_", @refs} = @types; |
301 | ok (eq_hash(\%h, \%expect), 'unblessed ref stringification'); |
302 | |
303 | bless $_ for @refs; |
304 | %h = (); %expect = (); |
305 | @h{@refs} = @types; |
306 | @expect{map "$_", @refs} = @types; |
307 | ok (eq_hash(\%h, \%expect), 'blessed ref stringification'); |
308 | } |