1N/A#!./perl
1N/A
1N/ABEGIN {
1N/A chdir 't' if -d 't';
1N/A @INC = '../lib';
1N/A require './test.pl';
1N/A}
1N/A
1N/Ause warnings;
1N/Ano warnings 'deprecated';
1N/Ause strict;
1N/Ause vars qw(@fake %fake);
1N/A
1N/Arequire Tie::Array;
1N/A
1N/Apackage Tie::BasicArray;
1N/A@Tie::BasicArray::ISA = 'Tie::Array';
1N/Asub TIEARRAY { bless [], $_[0] }
1N/Asub STORE { $_[0]->[$_[1]] = $_[2] }
1N/Asub FETCH { $_[0]->[$_[1]] }
1N/Asub FETCHSIZE { scalar(@{$_[0]})}
1N/Asub STORESIZE { $#{$_[0]} = $_[1]+1 }
1N/A
1N/Apackage main;
1N/A
1N/Aplan tests => 36;
1N/A
1N/Amy $sch = {
1N/A 'abc' => 1,
1N/A 'def' => 2,
1N/A 'jkl' => 3,
1N/A};
1N/A
1N/A# basic normal array
1N/A$a = [];
1N/A$a->[0] = $sch;
1N/A
1N/A$a->{'abc'} = 'ABC';
1N/A$a->{'def'} = 'DEF';
1N/A$a->{'jkl'} = 'JKL';
1N/A
1N/Amy @keys = keys %$a;
1N/Amy @values = values %$a;
1N/A
1N/Ais ($#keys, 2);
1N/Ais ($#values, 2);
1N/A
1N/Amy $i = 0; # stop -w complaints
1N/A
1N/Awhile (my ($key,$value) = each %$a) {
1N/A if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
1N/A $key =~ y/a-z/A-Z/;
1N/A $i++ if $key eq $value;
1N/A }
1N/A}
1N/A
1N/Ais ($i, 3);
1N/A
1N/A# quick check with tied array
1N/Atie @fake, 'Tie::StdArray';
1N/A$a = \@fake;
1N/A$a->[0] = $sch;
1N/A
1N/A$a->{'abc'} = 'ABC';
1N/Ais ($a->{'abc'}, 'ABC');
1N/A
1N/A# quick check with tied array
1N/Atie @fake, 'Tie::BasicArray';
1N/A$a = \@fake;
1N/A$a->[0] = $sch;
1N/A
1N/A$a->{'abc'} = 'ABC';
1N/Ais ($a->{'abc'}, 'ABC');
1N/A
1N/A# quick check with tied array & tied hash
1N/Arequire Tie::Hash;
1N/Atie %fake, 'Tie::StdHash';
1N/A%fake = %$sch;
1N/A$a->[0] = \%fake;
1N/A
1N/A$a->{'abc'} = 'ABC';
1N/Ais ($a->{'abc'}, 'ABC');
1N/A
1N/A# hash slice
1N/A{
1N/A no warnings 'uninitialized';
1N/A my $slice = join('', 'x',@$a{'abc','def'},'x');
1N/A is ($slice, 'xABCx');
1N/A}
1N/A
1N/A# evaluation in scalar context
1N/Amy $avhv = [{}];
1N/Aok (!%$avhv);
1N/A
1N/Apush @$avhv, "a";
1N/Aok (!%$avhv);
1N/A
1N/A$avhv = [];
1N/Aeval { $a = %$avhv };
1N/Alike ($@, qr/^Can't coerce array into hash/);
1N/A
1N/A$avhv = [{foo=>1, bar=>2}];
1N/Alike (%$avhv, qr,^\d+/\d+,);
1N/A
1N/A# check if defelem magic works
1N/Asub f {
1N/A is ($_[0], 'a');
1N/A $_[0] = 'b';
1N/A}
1N/A$a = [{key => 1}, 'a'];
1N/Af($a->{key});
1N/Ais ($a->[1], 'b');
1N/A
1N/A# check if exists() is behaving properly
1N/A$avhv = [{foo=>1,bar=>2,pants=>3}];
1N/Aok (!exists $avhv->{bar});
1N/A
1N/A$avhv->{pants} = undef;
1N/Aok (exists $avhv->{pants});
1N/Aok (!exists $avhv->{bar});
1N/A
1N/A$avhv->{bar} = 10;
1N/Aok (exists $avhv->{bar});
1N/Ais ($avhv->{bar}, 10);
1N/A
1N/Amy $v = delete $avhv->{bar};
1N/Ais ($v, 10);
1N/A
1N/Aok (!exists $avhv->{bar});
1N/A
1N/A$avhv->{foo} = 'xxx';
1N/A$avhv->{bar} = 'yyy';
1N/A$avhv->{pants} = 'zzz';
1N/Amy @x = delete @{$avhv}{'foo','pants'};
1N/Ais ("@x", "xxx zzz");
1N/A
1N/Ais ("$avhv->{bar}", "yyy");
1N/A
1N/A# hash assignment
1N/A%$avhv = ();
1N/Ais (ref($avhv->[0]), 'HASH');
1N/A
1N/Amy %hv = %$avhv;
1N/Aok (!grep defined, values %hv);
1N/Aok (!grep ref, keys %hv);
1N/A
1N/A%$avhv = (foo => 29, pants => 2, bar => 0);
1N/Ais ("@$avhv[1..3]", '29 0 2');
1N/A
1N/Amy $extra;
1N/Amy @extra;
1N/A($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!");
1N/Ais ("@$avhv[1..3]", '42 HIKE! 53');
1N/Ais ($extra, 'moo');
1N/A
1N/A%$avhv = ();
1N/A(%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!");
1N/Ais ("@$avhv[1..3]", '42 HIKE! 53');
1N/Aok (!defined $extra);
1N/A
1N/A@extra = qw(whatever and stuff);
1N/A%$avhv = ();
1N/A(%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!");
1N/Ais ("@$avhv[1..3]", '42 HIKE! 53');
1N/Ais (@extra, 0);
1N/A
1N/A%$avhv = ();
1N/A(@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!");
1N/Ais (ref $avhv->[0], 'HASH');
1N/Ais (@extra, 6);
1N/A
1N/A# Check hash slices (BUG ID 20010423.002)
1N/A$avhv = [{foo=>1, bar=>2}];
1N/A@$avhv{"foo", "bar"} = (42, 53);
1N/Ais ($avhv->{foo}, 42);
1N/Ais ($avhv->{bar}, 53);