1#!./perl -w 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7} 8 9# use strict; 10 11plan tests => 218; 12 13my @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 23my %comma = @comma; 24ok (keys %comma == 1, 'keys on comma hash'); 25ok (values %comma == 1, 'values on comma hash'); 26# defeat any tokeniser or optimiser cunning 27my $key = 'ey'; 28is ($comma{"k" . $key}, "value", 'is key present? (unoptimised)'); 29# now with cunning: 30is ($comma{key}, "value", 'is key present? (maybe optimised)'); 31#tokeniser may treat => differently. 32my @temp = (key=>undef); 33is ($comma{$temp[0]}, "value", 'is key present? (using LHS of =>)'); 34 35@temp = %comma; 36ok (eq_array (\@comma, \@temp), 'list from comma hash'); 37 38@temp = each %comma; 39ok (eq_array (\@comma, \@temp), 'first each from comma hash'); 40@temp = each %comma; 41ok (eq_array ([], \@temp), 'last each from comma hash'); 42 43my %temp = %comma; 44 45ok (keys %temp == 1, 'keys on copy of comma hash'); 46ok (values %temp == 1, 'values on copy of comma hash'); 47is ($temp{'k' . $key}, "value", 'is key present? (unoptimised)'); 48# now with cunning: 49is ($temp{key}, "value", 'is key present? (maybe optimised)'); 50@temp = (key=>undef); 51is ($comma{$temp[0]}, "value", 'is key present? (using LHS of =>)'); 52 53@temp = %temp; 54ok (eq_array (\@temp, \@temp), 'list from copy of comma hash'); 55 56@temp = each %temp; 57ok (eq_array (\@temp, \@temp), 'first each from copy of comma hash'); 58@temp = each %temp; 59ok (eq_array ([], \@temp), 'last each from copy of comma hash'); 60 61my @arrow = (Key =>"Value"); 62 63my %arrow = @arrow; 64ok (keys %arrow == 1, 'keys on arrow hash'); 65ok (values %arrow == 1, 'values on arrow hash'); 66# defeat any tokeniser or optimiser cunning 67$key = 'ey'; 68is ($arrow{"K" . $key}, "Value", 'is key present? (unoptimised)'); 69# now with cunning: 70is ($arrow{Key}, "Value", 'is key present? (maybe optimised)'); 71#tokeniser may treat => differently. 72@temp = ('Key', undef); 73is ($arrow{$temp[0]}, "Value", 'is key present? (using LHS of =>)'); 74 75@temp = %arrow; 76ok (eq_array (\@arrow, \@temp), 'list from arrow hash'); 77 78@temp = each %arrow; 79ok (eq_array (\@arrow, \@temp), 'first each from arrow hash'); 80@temp = each %arrow; 81ok (eq_array ([], \@temp), 'last each from arrow hash'); 82 83%temp = %arrow; 84 85ok (keys %temp == 1, 'keys on copy of arrow hash'); 86ok (values %temp == 1, 'values on copy of arrow hash'); 87is ($temp{'K' . $key}, "Value", 'is key present? (unoptimised)'); 88# now with cunning: 89is ($temp{Key}, "Value", 'is key present? (maybe optimised)'); 90@temp = ('Key', undef); 91is ($arrow{$temp[0]}, "Value", 'is key present? (using LHS of =>)'); 92 93@temp = %temp; 94ok (eq_array (\@temp, \@temp), 'list from copy of arrow hash'); 95 96@temp = each %temp; 97ok (eq_array (\@temp, \@temp), 'first each from copy of arrow hash'); 98@temp = each %temp; 99ok (eq_array ([], \@temp), 'last each from copy of arrow hash'); 100 101my %direct = ('Camel', 2, 'Dromedary', 1); 102my %slow; 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); 114%names = ('$' => 'Scalar', '@' => 'Array', # Grr ' 115 '%', 'Hash', '&', 'Code'); 116%names_copy = %names; 117ok (eq_hash (\%names, \%names_copy), "check we can copy our hash"); 118 119sub in { 120 my %args = @_; 121 return eq_hash (\%names, \%args); 122} 123 124ok (in (%names), "pass hash into a method"); 125 126sub in_method { 127 my $self = shift; 128 my %args = @_; 129 return eq_hash (\%names, \%args); 130} 131 132ok (main->in_method (%names), "pass hash into a method"); 133 134sub out { 135 return %names; 136} 137%names_copy = out (); 138 139ok (eq_hash (\%names, \%names_copy), "pass hash from a subroutine"); 140 141sub out_method { 142 my $self = shift; 143 return %names; 144} 145%names_copy = main->out_method (); 146 147ok (eq_hash (\%names, \%names_copy), "pass hash from a method"); 148 149sub in_out { 150 my %args = @_; 151 return %args; 152} 153%names_copy = in_out (%names); 154 155ok (eq_hash (\%names, \%names_copy), "pass hash to and from a subroutine"); 156 157sub in_out_method { 158 my $self = shift; 159 my %args = @_; 160 return %args; 161} 162%names_copy = main->in_out_method (%names); 163 164ok (eq_hash (\%names, \%names_copy), "pass hash to and from a method"); 165 166my %names_copy2 = %names; 167ok (eq_hash (\%names, \%names_copy2), "check copy worked"); 168 169# This should get ignored. 170%names_copy = ('%', 'Associative Array', %names); 171 172ok (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'; 178ok (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 183ok (eq_hash (\%names_copy, \%names_copy2), "duplicates at both ends"); 184 185# And now UTF8 186 187foreach 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], [perl #31865] 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( (join ':', %h = qw(a 1 a 2 b 3 c 4 d 5 d 6)), 'a:2:b:3:c:4:d:6', 282 'hash assignment in list context removes duplicates 2' ); 283 is( scalar( %h = (1,2,1,3,1,4,1,5) ), 2, 284 'hash assignment in scalar context' ); 285 is( scalar( ($x,%h) = (0,1,2,1,3,1,4,1,5) ), 3, 286 'scalar + hash assignment in scalar context' ); 287 $ar = [ %h = (1,2,1,3,1,4,1,5) ]; 288 is( $#$ar, 1, 'hash assignment in list context' ); 289 is( "@$ar", "1 5", '...gets the last values' ); 290 $ar = [ ($x,%h) = (0,1,2,1,3,1,4,1,5) ]; 291 is( $#$ar, 2, 'scalar + hash assignment in list context' ); 292 is( "@$ar", "0 1 5", '...gets the last values' ); 293} 294 295# test stringification of keys 296{ 297 no warnings 'once'; 298 my @types = qw( SCALAR ARRAY HASH CODE GLOB); 299 my @refs = ( \ do { my $x }, [], {}, sub {}, \ *x); 300 my(%h, %expect); 301 @h{@refs} = @types; 302 @expect{map "$_", @refs} = @types; 303 ok (eq_hash(\%h, \%expect), 'unblessed ref stringification'); 304 305 bless $_ for @refs; 306 %h = (); %expect = (); 307 @h{@refs} = @types; 308 @expect{map "$_", @refs} = @types; 309 ok (eq_hash(\%h, \%expect), 'blessed ref stringification'); 310} 311 312# [perl #76716] Hash assignment should not zap weak refs. 313SKIP: { 314 skip_if_miniperl("no dynamic loading on miniperl, no Scalar::Util", 2); 315 my %tb; 316 require Scalar::Util; 317 Scalar::Util::weaken(my $p = \%tb); 318 %tb = (); 319 is $p, \%tb, "hash assignment should not zap weak refs"; 320 undef %tb; 321 is $p, \%tb, "hash undef should not zap weak refs"; 322} 323