This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make exists() work better on pseudo-hashes (reworked a patch suggested
[perl5.git] / t / op / avhv.t
CommitLineData
5d5aaa5e 1#!./perl
a60c0954
NIS
2
3BEGIN {
4 chdir 't' if -d 't';
93430cb4 5 unshift @INC, '../lib';
a60c0954
NIS
6}
7
8require Tie::Array;
5d5aaa5e 9
a60c0954
NIS
10package Tie::BasicArray;
11@ISA = 'Tie::Array';
5d5aaa5e 12sub TIEARRAY { bless [], $_[0] }
a60c0954
NIS
13sub STORE { $_[0]->[$_[1]] = $_[2] }
14sub FETCH { $_[0]->[$_[1]] }
15sub FETCHSIZE { scalar(@{$_[0]})}
16sub STORESIZE { $#{$_[0]} = $_[1]+1 }
5d5aaa5e
JP
17
18package main;
19
4bd46447 20print "1..15\n";
5d5aaa5e
JP
21
22$sch = {
23 'abc' => 1,
24 'def' => 2,
25 'jkl' => 3,
26};
27
28# basic normal array
29$a = [];
30$a->[0] = $sch;
31
32$a->{'abc'} = 'ABC';
33$a->{'def'} = 'DEF';
34$a->{'jkl'} = 'JKL';
5d5aaa5e
JP
35
36@keys = keys %$a;
37@values = values %$a;
38
57079c46 39if ($#keys == 2 && $#values == 2) {print "ok 1\n";} else {print "not ok 1\n";}
5d5aaa5e
JP
40
41$i = 0; # stop -w complaints
42
43while (($key,$value) = each %$a) {
44 if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
45 $key =~ y/a-z/A-Z/;
46 $i++ if $key eq $value;
47 }
48}
49
57079c46 50if ($i == 3) {print "ok 2\n";} else {print "not ok 2\n";}
5d5aaa5e
JP
51
52# quick check with tied array
53tie @fake, 'Tie::StdArray';
54$a = \@fake;
55$a->[0] = $sch;
56
57$a->{'abc'} = 'ABC';
58if ($a->{'abc'} eq 'ABC') {print "ok 3\n";} else {print "not ok 3\n";}
59
a60c0954
NIS
60# quick check with tied array
61tie @fake, 'Tie::BasicArray';
62$a = \@fake;
63$a->[0] = $sch;
64
65$a->{'abc'} = 'ABC';
66if ($a->{'abc'} eq 'ABC') {print "ok 4\n";} else {print "not ok 4\n";}
67
5d5aaa5e 68# quick check with tied array & tied hash
5d5aaa5e
JP
69require Tie::Hash;
70tie %fake, Tie::StdHash;
71%fake = %$sch;
72$a->[0] = \%fake;
73
74$a->{'abc'} = 'ABC';
a60c0954 75if ($a->{'abc'} eq 'ABC') {print "ok 5\n";} else {print "not ok 5\n";}
800e9ae0
JP
76
77# hash slice
78my $slice = join('', 'x',@$a{'abc','def'},'x');
79print "not " if $slice ne 'xABCx';
80print "ok 6\n";
4b154ab5
GA
81
82# evaluation in scalar context
83my $avhv = [{}];
84print "not " if %$avhv;
85print "ok 7\n";
86
87push @$avhv, "a";
88print "not " if %$avhv;
89print "ok 8\n";
90
91$avhv = [];
92eval { $a = %$avhv };
93print "not " unless $@ and $@ =~ /^Can't coerce array into hash/;
94print "ok 9\n";
95
96$avhv = [{foo=>1, bar=>2}];
97print "not " unless %$avhv =~ m,^\d+/\d+,;
98print "ok 10\n";
74e13ce4
GS
99
100# check if defelem magic works
101sub f {
102 print "not " unless $_[0] eq 'a';
103 $_[0] = 'b';
104 print "ok 11\n";
105}
106$a = [{key => 1}, 'a'];
107f($a->{key});
108print "not " unless $a->[1] eq 'b';
109print "ok 12\n";
110
4bd46447
GS
111# check if exists() is behaving properly
112$avhv = [{foo=>1,bar=>2,pants=>3}];
113print "not " if exists $avhv->{bar};
114print "ok 13\n";
115
116$avhv->{pants} = undef;
117print "not " unless exists $avhv->{pants};
118print "ok 14\n";
119print "not " if exists $avhv->{bar};
120print "ok 15\n";