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