Move the require './test.pl' to the end of t/comp/hints.t
[p5sagit/p5-mst-13.2.git] / t / op / hashassign.t
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
11 plan tests => 215;
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
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 }
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 }