Commit | Line | Data |
---|---|---|
5d5aaa5e | 1 | #!./perl |
10c8fecd | 2 | |
a60c0954 NIS |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
20822f61 | 5 | @INC = '../lib'; |
a60c0954 NIS |
6 | } |
7 | ||
8 | require Tie::Array; | |
5d5aaa5e | 9 | |
a60c0954 NIS |
10 | package Tie::BasicArray; |
11 | @ISA = 'Tie::Array'; | |
5d5aaa5e | 12 | sub TIEARRAY { bless [], $_[0] } |
a60c0954 NIS |
13 | sub STORE { $_[0]->[$_[1]] = $_[2] } |
14 | sub FETCH { $_[0]->[$_[1]] } | |
15 | sub FETCHSIZE { scalar(@{$_[0]})} | |
16 | sub STORESIZE { $#{$_[0]} = $_[1]+1 } | |
5d5aaa5e JP |
17 | |
18 | package main; | |
19 | ||
e43e3698 | 20 | print "1..29\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 | 39 | if ($#keys == 2 && $#values == 2) {print "ok 1\n";} else {print "not ok 1\n";} |
5d5aaa5e JP |
40 | |
41 | $i = 0; # stop -w complaints | |
42 | ||
43 | while (($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 | 50 | if ($i == 3) {print "ok 2\n";} else {print "not ok 2\n";} |
5d5aaa5e JP |
51 | |
52 | # quick check with tied array | |
53 | tie @fake, 'Tie::StdArray'; | |
54 | $a = \@fake; | |
55 | $a->[0] = $sch; | |
56 | ||
57 | $a->{'abc'} = 'ABC'; | |
58 | if ($a->{'abc'} eq 'ABC') {print "ok 3\n";} else {print "not ok 3\n";} | |
59 | ||
a60c0954 NIS |
60 | # quick check with tied array |
61 | tie @fake, 'Tie::BasicArray'; | |
62 | $a = \@fake; | |
63 | $a->[0] = $sch; | |
64 | ||
65 | $a->{'abc'} = 'ABC'; | |
66 | if ($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 |
69 | require Tie::Hash; |
70 | tie %fake, Tie::StdHash; | |
71 | %fake = %$sch; | |
72 | $a->[0] = \%fake; | |
73 | ||
74 | $a->{'abc'} = 'ABC'; | |
a60c0954 | 75 | if ($a->{'abc'} eq 'ABC') {print "ok 5\n";} else {print "not ok 5\n";} |
800e9ae0 JP |
76 | |
77 | # hash slice | |
78 | my $slice = join('', 'x',@$a{'abc','def'},'x'); | |
79 | print "not " if $slice ne 'xABCx'; | |
80 | print "ok 6\n"; | |
4b154ab5 GA |
81 | |
82 | # evaluation in scalar context | |
83 | my $avhv = [{}]; | |
84 | print "not " if %$avhv; | |
85 | print "ok 7\n"; | |
86 | ||
87 | push @$avhv, "a"; | |
88 | print "not " if %$avhv; | |
89 | print "ok 8\n"; | |
90 | ||
91 | $avhv = []; | |
92 | eval { $a = %$avhv }; | |
93 | print "not " unless $@ and $@ =~ /^Can't coerce array into hash/; | |
94 | print "ok 9\n"; | |
95 | ||
96 | $avhv = [{foo=>1, bar=>2}]; | |
97 | print "not " unless %$avhv =~ m,^\d+/\d+,; | |
98 | print "ok 10\n"; | |
74e13ce4 GS |
99 | |
100 | # check if defelem magic works | |
101 | sub f { | |
102 | print "not " unless $_[0] eq 'a'; | |
103 | $_[0] = 'b'; | |
104 | print "ok 11\n"; | |
105 | } | |
106 | $a = [{key => 1}, 'a']; | |
107 | f($a->{key}); | |
108 | print "not " unless $a->[1] eq 'b'; | |
109 | print "ok 12\n"; | |
110 | ||
4bd46447 GS |
111 | # check if exists() is behaving properly |
112 | $avhv = [{foo=>1,bar=>2,pants=>3}]; | |
113 | print "not " if exists $avhv->{bar}; | |
114 | print "ok 13\n"; | |
115 | ||
116 | $avhv->{pants} = undef; | |
117 | print "not " unless exists $avhv->{pants}; | |
118 | print "ok 14\n"; | |
119 | print "not " if exists $avhv->{bar}; | |
120 | print "ok 15\n"; | |
01020589 GS |
121 | |
122 | $avhv->{bar} = 10; | |
123 | print "not " unless exists $avhv->{bar} and $avhv->{bar} == 10; | |
124 | print "ok 16\n"; | |
125 | ||
126 | $v = delete $avhv->{bar}; | |
127 | print "not " unless $v == 10; | |
128 | print "ok 17\n"; | |
129 | ||
130 | print "not " if exists $avhv->{bar}; | |
131 | print "ok 18\n"; | |
132 | ||
133 | $avhv->{foo} = 'xxx'; | |
134 | $avhv->{bar} = 'yyy'; | |
135 | $avhv->{pants} = 'zzz'; | |
136 | @x = delete @{$avhv}{'foo','pants'}; | |
137 | print "# @x\nnot " unless "@x" eq "xxx zzz"; | |
138 | print "ok 19\n"; | |
139 | ||
140 | print "not " unless "$avhv->{bar}" eq "yyy"; | |
141 | print "ok 20\n"; | |
10c8fecd GS |
142 | |
143 | # hash assignment | |
144 | %$avhv = (); | |
145 | print "not " unless ref($avhv->[0]) eq 'HASH'; | |
146 | print "ok 21\n"; | |
147 | ||
148 | %hv = %$avhv; | |
149 | print "not " if grep defined, values %hv; | |
150 | print "ok 22\n"; | |
151 | print "not " if grep ref, keys %hv; | |
152 | print "ok 23\n"; | |
153 | ||
154 | %$avhv = (foo => 29, pants => 2, bar => 0); | |
155 | print "not " unless "@$avhv[1..3]" eq '29 0 2'; | |
156 | print "ok 24\n"; | |
157 | ||
158 | my $extra; | |
159 | my @extra; | |
160 | ($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!"); | |
161 | print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and $extra eq 'moo'; | |
162 | print "ok 25\n"; | |
163 | ||
164 | %$avhv = (); | |
165 | (%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!"); | |
166 | print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and !defined $extra; | |
167 | print "ok 26\n"; | |
168 | ||
169 | @extra = qw(whatever and stuff); | |
170 | %$avhv = (); | |
171 | (%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!"); | |
172 | print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and @extra == 0; | |
173 | print "ok 27\n"; | |
174 | ||
175 | %$avhv = (); | |
176 | (@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!"); | |
177 | print "not " unless ref $avhv->[0] eq 'HASH' and @extra == 6; | |
178 | print "ok 28\n"; | |
e43e3698 RH |
179 | |
180 | # Check hash slices (BUG ID 20010423.002) | |
181 | $avhv = [{foo=>1, bar=>2}]; | |
182 | @$avhv{"foo", "bar"} = (42, 53); | |
183 | print "not " unless $avhv->{foo} == 42 && $avhv->{bar} == 53; | |
184 | print "ok 29\n"; |