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