1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7} 8use strict; 9use warnings; 10no warnings 'deprecated', 'experimental::autoderef'; 11use vars qw($data $array $values $hash $errpat); 12 13plan 'no_plan'; 14 15sub j { join(":",@_) } 16 17# NOTE 18# 19# Hash insertion is currently unstable, in that 20# %hash= %otherhash will not necessarily result in 21# the same internal ordering of the data in the hash. 22# For instance when keys collide the copy may not 23# match the inserted order. So we declare one hash 24# and then make all our copies from that, which should 25# mean all the copies have the same internal structure. 26# 27# And these days, even if all that weren't true, we now 28# per-hash randomize keys/values. So, we cant expect two 29# hashes with the same internal structure to return the 30# same thing at all. All we *can* expect is that keys() 31# and values() use the same ordering. 32our %base_hash; 33 34BEGIN { # in BEGIN for "use constant ..." later 35 # values match keys here so we can easily check that keys(%hash) == values(%hash) 36 %base_hash= ( pi => 'pi', e => 'e', i => 'i' ); 37 $array = [ qw(pi e i) ]; 38 $values = [ qw(pi e i) ]; 39 $hash = { %base_hash } ; 40 $data = { 41 hash => { %base_hash }, 42 array => [ @$array ], 43 }; 44} 45 46package Foo; 47sub new { 48 my $self = { 49 hash => { %base_hash }, 50 array => [@{$main::array}] 51 }; 52 bless $self, shift; 53} 54sub hash { no overloading; $_[0]->{hash} }; 55sub array { no overloading; $_[0]->{array} }; 56 57package Foo::Overload::Array; 58sub new { return bless [ qw/foo bar/ ], shift } 59use overload '@{}' => sub { $main::array }, fallback => 1; 60 61package Foo::Overload::Hash; 62sub new { return bless { qw/foo bar/ }, shift } 63use overload '%{}' => sub { $main::hash }, fallback => 1; 64 65package Foo::Overload::Both; 66sub new { return bless { qw/foo bar/ }, shift } 67use overload '%{}' => sub { $main::hash }, 68 '@{}' => sub { $main::array }, fallback => 1; 69 70package Foo::Overload::HashOnArray; 71sub new { return bless [ qw/foo bar/ ], shift } 72use overload '%{}' => sub { $main::hash }, fallback => 1; 73 74package Foo::Overload::ArrayOnHash; 75sub new { return bless { qw/foo bar/ }, shift } 76use overload '@{}' => sub { $main::array }, fallback => 1; 77 78package main; 79 80use constant CONST_HASH => { %base_hash }; 81use constant CONST_ARRAY => [ @$array ]; 82 83my %a_hash = %base_hash; 84my @an_array = @$array; 85sub hash_sub { return \%a_hash; } 86sub array_sub { return \@an_array; } 87 88my $obj = Foo->new; 89 90my ($empty, $h_expect, $a_expect, @tmp, @tmp2, $k, $v); 91 92# Keys -- void 93 94keys $hash; pass('Void: keys $hash;'); 95keys $data->{hash}; pass('Void: keys $data->{hash};'); 96keys CONST_HASH; pass('Void: keys CONST_HASH;'); 97keys CONST_HASH(); pass('Void: keys CONST_HASH();'); 98keys hash_sub(); pass('Void: keys hash_sub();'); 99keys hash_sub; pass('Void: keys hash_sub;'); 100keys $obj->hash; pass('Void: keys $obj->hash;'); 101keys $array; pass('Void: keys $array;'); 102keys $data->{array}; pass('Void: keys $data->{array};'); 103keys CONST_ARRAY; pass('Void: keys CONST_ARRAY;'); 104keys CONST_ARRAY(); pass('Void: keys CONST_ARRAY();'); 105keys array_sub; pass('Void: keys array_sub;'); 106keys array_sub(); pass('Void: keys array_sub();'); 107keys $obj->array; pass('Void: keys $obj->array;'); 108 109# Keys -- scalar 110 111is(keys $hash ,3, 'Scalar: keys $hash'); 112is(keys $data->{hash} ,3, 'Scalar: keys $data->{hash}'); 113is(keys CONST_HASH ,3, 'Scalar: keys CONST_HASH'); 114is(keys CONST_HASH() ,3, 'Scalar: keys CONST_HASH()'); 115is(keys hash_sub ,3, 'Scalar: keys hash_sub'); 116is(keys hash_sub() ,3, 'Scalar: keys hash_sub()'); 117is(keys $obj->hash ,3, 'Scalar: keys $obj->hash'); 118is(keys $array ,3, 'Scalar: keys $array'); 119is(keys $data->{array} ,3, 'Scalar: keys $data->{array}'); 120is(keys CONST_ARRAY ,3, 'Scalar: keys CONST_ARRAY'); 121is(keys CONST_ARRAY() ,3, 'Scalar: keys CONST_ARRAY()'); 122is(keys array_sub ,3, 'Scalar: keys array_sub'); 123is(keys array_sub() ,3, 'Scalar: keys array_sub()'); 124is(keys $obj->array ,3, 'Scalar: keys $obj->array'); 125 126# Keys -- list 127 128$h_expect = j(sort keys %base_hash); 129$a_expect = j(keys @$array); 130 131is(j(sort keys $hash) ,$h_expect, 'List: sort keys $hash'); 132is(j(sort keys $data->{hash}) ,$h_expect, 'List: sort keys $data->{hash}'); 133is(j(sort keys CONST_HASH) ,$h_expect, 'List: sort keys CONST_HASH'); 134is(j(sort keys CONST_HASH()) ,$h_expect, 'List: sort keys CONST_HASH()'); 135is(j(sort keys hash_sub) ,$h_expect, 'List: sort keys hash_sub'); 136is(j(sort keys hash_sub()) ,$h_expect, 'List: sort keys hash_sub()'); 137is(j(sort keys $obj->hash) ,$h_expect, 'List: sort keys $obj->hash'); 138 139is(j(keys $hash) ,j(values $hash), 'List: keys $hash == values $hash'); 140is(j(keys $data->{hash}) ,j(values $data->{hash}), 'List: keys $data->{hash} == values $data->{hash}'); 141is(j(keys CONST_HASH) ,j(values CONST_HASH), 'List: keys CONST_HASH == values CONST_HASH'); 142is(j(keys CONST_HASH()) ,j(values CONST_HASH()), 'List: keys CONST_HASH() == values CONST_HASH()'); 143is(j(keys hash_sub) ,j(values hash_sub), 'List: keys hash_sub == values hash_sub'); 144is(j(keys hash_sub()) ,j(values hash_sub()), 'List: keys hash_sub() == values hash_sub()'); 145is(j(keys $obj->hash) ,j(values $obj->hash), 'List: keys $obj->hash == values obj->hash'); 146 147is(j(keys $array) ,$a_expect, 'List: keys $array'); 148is(j(keys $data->{array}) ,$a_expect, 'List: keys $data->{array}'); 149is(j(keys CONST_ARRAY) ,$a_expect, 'List: keys CONST_ARRAY'); 150is(j(keys CONST_ARRAY()) ,$a_expect, 'List: keys CONST_ARRAY()'); 151is(j(keys array_sub) ,$a_expect, 'List: keys array_sub'); 152is(j(keys array_sub()) ,$a_expect, 'List: keys array_sub()'); 153is(j(keys $obj->array) ,$a_expect, 'List: keys $obj->array'); 154 155# Keys -- vivification 156undef $empty; 157eval { keys $empty->{hash} }; 158ok(defined $empty, 159 'Vivify: $empty (after keys $empty->{hash}) is HASHREF'); 160ok(!defined $empty->{hash} , 'Vivify: $empty->{hash} is undef'); 161 162# Keys -- lvalue 163$_{foo} = "bar"; 164keys \%_ = 65; 165is scalar %_, '1/128', 'keys $hashref as lvalue'; 166eval 'keys \@_ = 65'; 167like $@, qr/Can't modify keys on reference in scalar assignment/, 168 'keys $arrayref as lvalue dies'; 169 170# Keys -- errors 171$errpat = qr/ 172 (?-x:Type of argument to keys on reference must be unblessed hashref or) 173 (?-x: arrayref) 174/x; 175 176eval "keys undef"; 177ok($@ =~ $errpat, 178 'Errors: keys undef throws error' 179); 180 181undef $empty; 182eval q"keys $empty"; 183ok($@ =~ $errpat, 184 'Errors: keys $undef throws error' 185); 186 187is($empty, undef, 'keys $undef does not vivify $undef'); 188 189eval "keys 3"; 190ok($@ =~ qr/Type of arg 1 to keys must be hash/, 191 'Errors: keys CONSTANT throws error' 192); 193 194eval "keys qr/foo/"; 195ok($@ =~ $errpat, 196 'Errors: keys qr/foo/ throws error' 197); 198 199eval q"keys $hash qw/fo bar/"; 200ok($@ =~ qr/syntax error/, 201 'Errors: keys $hash, @stuff throws error' 202) or print "# Got: $@"; 203 204# Values -- void 205 206values $hash; pass('Void: values $hash;'); 207values $data->{hash}; pass('Void: values $data->{hash};'); 208values CONST_HASH; pass('Void: values CONST_HASH;'); 209values CONST_HASH(); pass('Void: values CONST_HASH();'); 210values hash_sub(); pass('Void: values hash_sub();'); 211values hash_sub; pass('Void: values hash_sub;'); 212values $obj->hash; pass('Void: values $obj->hash;'); 213values $array; pass('Void: values $array;'); 214values $data->{array}; pass('Void: values $data->{array};'); 215values CONST_ARRAY; pass('Void: values CONST_ARRAY;'); 216values CONST_ARRAY(); pass('Void: values CONST_ARRAY();'); 217values array_sub; pass('Void: values array_sub;'); 218values array_sub(); pass('Void: values array_sub();'); 219values $obj->array; pass('Void: values $obj->array;'); 220 221# Values -- scalar 222 223is(values $hash ,3, 'Scalar: values $hash'); 224is(values $data->{hash} ,3, 'Scalar: values $data->{hash}'); 225is(values CONST_HASH ,3, 'Scalar: values CONST_HASH'); 226is(values CONST_HASH() ,3, 'Scalar: values CONST_HASH()'); 227is(values hash_sub ,3, 'Scalar: values hash_sub'); 228is(values hash_sub() ,3, 'Scalar: values hash_sub()'); 229is(values $obj->hash ,3, 'Scalar: values $obj->hash'); 230is(values $array ,3, 'Scalar: values $array'); 231is(values $data->{array} ,3, 'Scalar: values $data->{array}'); 232is(values CONST_ARRAY ,3, 'Scalar: values CONST_ARRAY'); 233is(values CONST_ARRAY() ,3, 'Scalar: values CONST_ARRAY()'); 234is(values array_sub ,3, 'Scalar: values array_sub'); 235is(values array_sub() ,3, 'Scalar: values array_sub()'); 236is(values $obj->array ,3, 'Scalar: values $obj->array'); 237 238# Values -- list 239 240$h_expect = j(sort values %base_hash); 241$a_expect = j(values @$array); 242 243is(j(sort values $hash) ,$h_expect, 'List: sort values $hash'); 244is(j(sort values $data->{hash}) ,$h_expect, 'List: sort values $data->{hash}'); 245is(j(sort values CONST_HASH) ,$h_expect, 'List: sort values CONST_HASH'); 246is(j(sort values CONST_HASH()) ,$h_expect, 'List: sort values CONST_HASH()'); 247is(j(sort values hash_sub) ,$h_expect, 'List: sort values hash_sub'); 248is(j(sort values hash_sub()) ,$h_expect, 'List: sort values hash_sub()'); 249is(j(sort values $obj->hash) ,$h_expect, 'List: sort values $obj->hash'); 250 251is(j(values $hash) ,j(keys $hash), 'List: values $hash == keys $hash'); 252is(j(values $data->{hash}) ,j(keys $data->{hash}), 'List: values $data->{hash} == keys $data->{hash}'); 253is(j(values CONST_HASH) ,j(keys CONST_HASH), 'List: values CONST_HASH == keys CONST_HASH'); 254is(j(values CONST_HASH()) ,j(keys CONST_HASH()), 'List: values CONST_HASH() == keys CONST_HASH()'); 255is(j(values hash_sub) ,j(keys hash_sub), 'List: values hash_sub == keys hash_sub'); 256is(j(values hash_sub()) ,j(keys hash_sub()), 'List: values hash_sub() == keys hash_sub()'); 257is(j(values $obj->hash) ,j(keys $obj->hash), 'List: values $obj->hash == keys $obj->hash'); 258 259is(j(values $array) ,$a_expect, 'List: values $array'); 260is(j(values $data->{array}) ,$a_expect, 'List: values $data->{array}'); 261is(j(values CONST_ARRAY) ,$a_expect, 'List: values CONST_ARRAY'); 262is(j(values CONST_ARRAY()) ,$a_expect, 'List: values CONST_ARRAY()'); 263is(j(values array_sub) ,$a_expect, 'List: values array_sub'); 264is(j(values array_sub()) ,$a_expect, 'List: values array_sub()'); 265is(j(values $obj->array) ,$a_expect, 'List: values $obj->array'); 266 267# Values -- vivification 268undef $empty; 269eval { values $empty->{hash} }; 270ok(defined $empty, 271 'Vivify: $empty (after values $empty->{hash}) is HASHREF'); 272ok(!defined $empty->{hash} , 'Vivify: $empty->{hash} is undef'); 273 274# Values -- errors 275$errpat = qr/ 276 (?-x:Type of argument to values on reference must be unblessed hashref or) 277 (?-x: arrayref) 278/x; 279 280eval "values undef"; 281ok($@ =~ $errpat, 282 'Errors: values undef throws error' 283); 284 285undef $empty; 286eval q"values $empty"; 287ok($@ =~ $errpat, 288 'Errors: values $undef throws error' 289); 290 291is($empty, undef, 'values $undef does not vivify $undef'); 292 293eval "values 3"; 294ok($@ =~ qr/Type of arg 1 to values must be hash/, 295 'Errors: values CONSTANT throws error' 296); 297 298eval "values qr/foo/"; 299ok($@ =~ $errpat, 300 'Errors: values qr/foo/ throws error' 301); 302 303eval q"values $hash qw/fo bar/"; 304ok($@ =~ qr/syntax error/, 305 'Errors: values $hash, @stuff throws error' 306) or print "# Got: $@"; 307 308# Each -- void 309 310each $hash; pass('Void: each $hash'); 311each $data->{hash}; pass('Void: each $data->{hash}'); 312each CONST_HASH; pass('Void: each CONST_HASH'); 313each CONST_HASH(); pass('Void: each CONST_HASH()'); 314each hash_sub(); pass('Void: each hash_sub()'); 315each hash_sub; pass('Void: each hash_sub'); 316each $obj->hash; pass('Void: each $obj->hash'); 317each $array; pass('Void: each $array'); 318each $data->{array}; pass('Void: each $data->{array}'); 319each CONST_ARRAY; pass('Void: each CONST_ARRAY'); 320each CONST_ARRAY(); pass('Void: each CONST_ARRAY()'); 321each array_sub; pass('Void: each array_sub'); 322each array_sub(); pass('Void: each array_sub()'); 323each $obj->array; pass('Void: each $obj->array'); 324 325# Reset iterators 326 327keys $hash; 328keys $data->{hash}; 329keys CONST_HASH; 330keys CONST_HASH(); 331keys hash_sub(); 332keys hash_sub; 333keys $obj->hash; 334keys $array; 335keys $data->{array}; 336keys CONST_ARRAY; 337keys CONST_ARRAY(); 338keys array_sub; 339keys array_sub(); 340keys $obj->array; 341 342# Each -- scalar 343 344@tmp=(); while(defined( $k = each $hash)) {push @tmp,$k}; is(j(@tmp),j(keys $hash), 'Scalar: each $hash'); 345@tmp=(); while(defined( $k = each $data->{hash})){push @tmp,$k}; is(j(@tmp),j(keys $data->{hash}), 'Scalar: each $data->{hash}'); 346@tmp=(); while(defined( $k = each CONST_HASH)){push @tmp,$k}; is(j(@tmp),j(keys CONST_HASH), 'Scalar: each CONST_HASH'); 347@tmp=(); while(defined( $k = each CONST_HASH())){push @tmp,$k}; is(j(@tmp),j(keys CONST_HASH()), 'Scalar: each CONST_HASH()'); 348@tmp=(); while(defined( $k = each hash_sub())){push @tmp,$k}; is(j(@tmp),j(keys hash_sub()), 'Scalar: each hash_sub()'); 349@tmp=(); while(defined( $k = each hash_sub)){push @tmp,$k}; is(j(@tmp),j(keys hash_sub), 'Scalar: each hash_sub'); 350@tmp=(); while(defined( $k = each $obj->hash)){push @tmp,$k}; is(j(@tmp),j(keys $obj->hash), 'Scalar: each $obj->hash'); 351@tmp=(); while(defined( $k = each $array)){push @tmp,$k}; is(j(@tmp),j(keys $array), 'Scalar: each $array'); 352@tmp=(); while(defined( $k = each $data->{array})){push @tmp,$k}; is(j(@tmp),j(keys $data->{array}), 'Scalar: each $data->{array}'); 353@tmp=(); while(defined( $k = each CONST_ARRAY)){push @tmp,$k}; is(j(@tmp),j(keys CONST_ARRAY), 'Scalar: each CONST_ARRAY'); 354@tmp=(); while(defined( $k = each CONST_ARRAY())){push @tmp,$k}; is(j(@tmp),j(keys CONST_ARRAY()), 'Scalar: each CONST_ARRAY()'); 355@tmp=(); while(defined( $k = each array_sub)){push @tmp,$k}; is(j(@tmp),j(keys array_sub), 'Scalar: each array_sub'); 356@tmp=(); while(defined( $k = each array_sub())){push @tmp,$k}; is(j(@tmp),j(keys array_sub()), 'Scalar: each array_sub()'); 357@tmp=(); while(defined( $k = each $obj->array)){push @tmp,$k}; is(j(@tmp),j(keys $obj->array), 'Scalar: each $obj->array'); 358 359# Each -- list 360 361@tmp=@tmp2=(); while(($k,$v) = each $hash) {push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $hash, values $hash), 'List: each $hash'); 362@tmp=@tmp2=(); while(($k,$v) = each $data->{hash}){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $data->{hash}, values $data->{hash}), 'List: each $data->{hash}'); 363@tmp=@tmp2=(); while(($k,$v) = each CONST_HASH){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys CONST_HASH, values CONST_HASH), 'List: each CONST_HASH'); 364@tmp=@tmp2=(); while(($k,$v) = each CONST_HASH()){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys CONST_HASH(), values CONST_HASH()), 'List: each CONST_HASH()'); 365@tmp=@tmp2=(); while(($k,$v) = each hash_sub()){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys hash_sub(), values hash_sub()), 'List: each hash_sub()'); 366@tmp=@tmp2=(); while(($k,$v) = each hash_sub){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys hash_sub, values hash_sub), 'List: each hash_sub'); 367@tmp=@tmp2=(); while(($k,$v) = each $obj->hash){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $obj->hash, values $obj->hash), 'List: each $obj->hash'); 368@tmp=@tmp2=(); while(($k,$v) = each $array){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $array, values $array), 'List: each $array'); 369@tmp=@tmp2=(); while(($k,$v) = each $data->{array}){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $data->{array}, values $data->{array}), 'List: each $data->{array}'); 370@tmp=@tmp2=(); while(($k,$v) = each CONST_ARRAY){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys CONST_ARRAY, values CONST_ARRAY), 'List: each CONST_ARRAY'); 371@tmp=@tmp2=(); while(($k,$v) = each CONST_ARRAY()){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys CONST_ARRAY(), values CONST_ARRAY()), 'List: each CONST_ARRAY()'); 372@tmp=@tmp2=(); while(($k,$v) = each array_sub){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys array_sub, values array_sub), 'List: each array_sub'); 373@tmp=@tmp2=(); while(($k,$v) = each array_sub()){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys array_sub(), values array_sub()), 'List: each array_sub()'); 374@tmp=@tmp2=(); while(($k,$v) = each $obj->array){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $obj->array, values $obj->array), 'List: each $obj->array'); 375 376# Each -- vivification 377undef $empty; 378eval { each $empty->{hash} }; 379ok(defined $empty, 380 'Vivify: $empty (after each $empty->{hash}) is HASHREF'); 381ok(!defined $empty->{hash} , 'Vivify: $empty->{hash} is undef'); 382 383# Each -- errors 384$errpat = qr/ 385 (?-x:Type of argument to each on reference must be unblessed hashref or) 386 (?-x: arrayref) 387/x; 388 389eval "each undef"; 390ok($@ =~ $errpat, 391 'Errors: each undef throws error' 392); 393 394undef $empty; 395eval q"each $empty"; 396ok($@ =~ $errpat, 397 'Errors: each $undef throws error' 398); 399 400is($empty, undef, 'each $undef does not vivify $undef'); 401 402eval "each 3"; 403ok($@ =~ qr/Type of arg 1 to each must be hash/, 404 'Errors: each CONSTANT throws error' 405); 406 407eval "each qr/foo/"; 408ok($@ =~ $errpat, 409 'Errors: each qr/foo/ throws error' 410); 411 412eval q"each $hash qw/foo bar/"; 413ok($@ =~ qr/syntax error/, 414 'Errors: each $hash, @stuff throws error' 415) or print "# Got: $@"; 416 417# Overloaded objects 418my $over_a = Foo::Overload::Array->new; 419my $over_h = Foo::Overload::Hash->new; 420my $over_b = Foo::Overload::Both->new; 421my $over_h_a = Foo::Overload::HashOnArray->new; 422my $over_a_h = Foo::Overload::ArrayOnHash->new; 423 424{ 425 my $warn = ''; 426 local $SIG{__WARN__} = sub { $warn = shift }; 427 428 $errpat = qr/ 429 (?-x:Type of argument to keys on reference must be unblessed hashref or) 430 (?-x: arrayref) 431 /x; 432 433 eval { keys $over_a }; 434 like($@, $errpat, "Overload: array dereference"); 435 is($warn, '', "no warning issued"); $warn = ''; 436 437 eval { keys $over_h }; 438 like($@, $errpat, "Overload: hash dereference"); 439 is($warn, '', "no warning issued"); $warn = ''; 440 441 eval { keys $over_b }; 442 like($@, $errpat, "Overload: ambiguous dereference (both)"); 443 is($warn, '', "no warning issued"); $warn = ''; 444 445 eval { keys $over_h_a }; 446 like($@, $errpat, "Overload: ambiguous dereference"); 447 is($warn, '', "no warning issued"); $warn = ''; 448 449 eval { keys $over_a_h }; 450 like($@, $errpat, "Overload: ambiguous dereference"); 451 is($warn, '', "no warning issued"); $warn = ''; 452} 453