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 => 238;
  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],  [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) ), 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';
 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.
 313 SKIP: {
 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
 324 # test odd hash assignment warnings
 325 {
 326     my ($s, %h);
 327     warning_like(sub {%h = (1..3)}, qr/^Odd number of elements in hash assignment/);
 328     warning_like(sub {%h = ({})}, qr/^Reference found where even-sized list expected/);
 329
 330     warning_like(sub { ($s, %h) = (1..4)}, qr/^Odd number of elements in hash assignment/);
 331     warning_like(sub { ($s, %h) = (1, {})}, qr/^Reference found where even-sized list expected/);
 332 }
 333
 334 # hash assignment in scalar and list context with odd number of elements
 335 {
 336     no warnings 'misc', 'uninitialized';
 337     my %h; my $x;
 338     is( join( ':', %h = (1..3)), '1:2:3:',
 339         'odd hash assignment in list context' );
 340     ok( eq_hash( \%h, {1 => 2, 3 => undef} ), "correct value stored" );
 341     is( scalar( %h = (1..3) ), 3,
 342         'odd hash assignment in scalar context' );
 343     ok( eq_hash( \%h, {1 => 2, 3 => undef} ), "correct value stored" );
 344     is( join(':', ($x,%h) = (0,1,2,3) ), '0:1:2:3:',
 345         'scalar + odd hash assignment in list context' );
 346     ok( eq_hash( \%h, {1 => 2, 3 => undef} ), "correct value stored" );
 347     is( scalar( ($x,%h) = (0,1,2,3) ), 4,
 348         'scalar + odd hash assignment in scalar context' );
 349     ok( eq_hash( \%h, {1 => 2, 3 => undef} ), "correct value stored" );
 350 }
 351
 352 # hash assignment in scalar and list context with odd number of elements
 353 # and duplicates
 354 {
 355     no warnings 'misc', 'uninitialized';
 356     my %h; my $x;
 357     is( (join ':', %h = (1,1,1)), '1:',
 358         'odd hash assignment in list context with duplicates' );
 359     ok( eq_hash( \%h, {1 => undef} ), "correct value stored" );
 360     is( scalar(%h = (1,1,1)), 3,
 361         'odd hash assignment in scalar context with duplicates' );
 362     ok( eq_hash( \%h, {1 => undef} ), "correct value stored" );
 363     is( join(':', ($x,%h) = (0,1,1,1) ), '0:1:',
 364         'scalar + odd hash assignment in list context with duplicates' );
 365     ok( eq_hash( \%h, {1 => undef} ), "correct value stored" );
 366     is( scalar( ($x,%h) = (0,1,1,1) ), 4,
 367         'scalar + odd hash assignment in scalar context with duplicates' );
 368     ok( eq_hash( \%h, {1 => undef} ), "correct value stored" );
 369 }
 370
 371