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