1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7} 8 9use warnings; 10no warnings 'deprecated'; 11use strict; 12use vars qw(@fake %fake); 13 14require Tie::Array; 15 16package Tie::BasicArray; 17@Tie::BasicArray::ISA = 'Tie::Array'; 18sub TIEARRAY { bless [], $_[0] } 19sub STORE { $_[0]->[$_[1]] = $_[2] } 20sub FETCH { $_[0]->[$_[1]] } 21sub FETCHSIZE { scalar(@{$_[0]})} 22sub STORESIZE { $#{$_[0]} = $_[1]+1 } 23 24package main; 25 26plan tests => 36; 27 28my $sch = { 29 'abc' => 1, 30 'def' => 2, 31 'jkl' => 3, 32}; 33 34# basic normal array 35$a = []; 36$a->[0] = $sch; 37 38$a->{'abc'} = 'ABC'; 39$a->{'def'} = 'DEF'; 40$a->{'jkl'} = 'JKL'; 41 42my @keys = keys %$a; 43my @values = values %$a; 44 45is ($#keys, 2); 46is ($#values, 2); 47 48my $i = 0; # stop -w complaints 49 50while (my ($key,$value) = each %$a) { 51 if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { 52 $key =~ y/a-z/A-Z/; 53 $i++ if $key eq $value; 54 } 55} 56 57is ($i, 3); 58 59# quick check with tied array 60tie @fake, 'Tie::StdArray'; 61$a = \@fake; 62$a->[0] = $sch; 63 64$a->{'abc'} = 'ABC'; 65is ($a->{'abc'}, 'ABC'); 66 67# quick check with tied array 68tie @fake, 'Tie::BasicArray'; 69$a = \@fake; 70$a->[0] = $sch; 71 72$a->{'abc'} = 'ABC'; 73is ($a->{'abc'}, 'ABC'); 74 75# quick check with tied array & tied hash 76require Tie::Hash; 77tie %fake, 'Tie::StdHash'; 78%fake = %$sch; 79$a->[0] = \%fake; 80 81$a->{'abc'} = 'ABC'; 82is ($a->{'abc'}, 'ABC'); 83 84# hash slice 85{ 86 no warnings 'uninitialized'; 87 my $slice = join('', 'x',@$a{'abc','def'},'x'); 88 is ($slice, 'xABCx'); 89} 90 91# evaluation in scalar context 92my $avhv = [{}]; 93ok (!%$avhv); 94 95push @$avhv, "a"; 96ok (!%$avhv); 97 98$avhv = []; 99eval { $a = %$avhv }; 100like ($@, qr/^Can't coerce array into hash/); 101 102$avhv = [{foo=>1, bar=>2}]; 103like (%$avhv, qr,^\d+/\d+,); 104 105# check if defelem magic works 106sub f { 107 is ($_[0], 'a'); 108 $_[0] = 'b'; 109} 110$a = [{key => 1}, 'a']; 111f($a->{key}); 112is ($a->[1], 'b'); 113 114# check if exists() is behaving properly 115$avhv = [{foo=>1,bar=>2,pants=>3}]; 116ok (!exists $avhv->{bar}); 117 118$avhv->{pants} = undef; 119ok (exists $avhv->{pants}); 120ok (!exists $avhv->{bar}); 121 122$avhv->{bar} = 10; 123ok (exists $avhv->{bar}); 124is ($avhv->{bar}, 10); 125 126my $v = delete $avhv->{bar}; 127is ($v, 10); 128 129ok (!exists $avhv->{bar}); 130 131$avhv->{foo} = 'xxx'; 132$avhv->{bar} = 'yyy'; 133$avhv->{pants} = 'zzz'; 134my @x = delete @{$avhv}{'foo','pants'}; 135is ("@x", "xxx zzz"); 136 137is ("$avhv->{bar}", "yyy"); 138 139# hash assignment 140%$avhv = (); 141is (ref($avhv->[0]), 'HASH'); 142 143my %hv = %$avhv; 144ok (!grep defined, values %hv); 145ok (!grep ref, keys %hv); 146 147%$avhv = (foo => 29, pants => 2, bar => 0); 148is ("@$avhv[1..3]", '29 0 2'); 149 150my $extra; 151my @extra; 152($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!"); 153is ("@$avhv[1..3]", '42 HIKE! 53'); 154is ($extra, 'moo'); 155 156%$avhv = (); 157(%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!"); 158is ("@$avhv[1..3]", '42 HIKE! 53'); 159ok (!defined $extra); 160 161@extra = qw(whatever and stuff); 162%$avhv = (); 163(%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!"); 164is ("@$avhv[1..3]", '42 HIKE! 53'); 165is (@extra, 0); 166 167%$avhv = (); 168(@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!"); 169is (ref $avhv->[0], 'HASH'); 170is (@extra, 6); 171 172# Check hash slices (BUG ID 20010423.002) 173$avhv = [{foo=>1, bar=>2}]; 174@$avhv{"foo", "bar"} = (42, 53); 175is ($avhv->{foo}, 42); 176is ($avhv->{bar}, 53); 177