Small optimisations, by Brandon Black
[p5sagit/p5-mst-13.2.git] / t / op / avhv.t
1 #!./perl
2
3 # This test was originally for pseudo-hashes.  It now exists to ensure
4 # they were properly removed in 5.9.
5
6 BEGIN {
7     chdir 't' if -d 't';
8     @INC = '../lib';
9 }
10
11 require Tie::Array;
12
13 package Tie::BasicArray;
14 @ISA = 'Tie::Array';
15 sub TIEARRAY  { bless [], $_[0] }
16 sub STORE     { $_[0]->[$_[1]] = $_[2] }
17 sub FETCH     { $_[0]->[$_[1]] }
18 sub FETCHSIZE { scalar(@{$_[0]})} 
19 sub STORESIZE { $#{$_[0]} = $_[1]+1 }
20
21 package main;
22
23 require './test.pl';
24 plan(tests => 40);
25
26 # Helper function to check the typical error message.
27 sub not_hash {
28     my($err) = shift;
29     like( $err, qr/^Not a HASH reference / ) ||
30       printf STDERR "# at %s line %d.\n", (caller)[1,2];
31 }
32
33 # Something to place inside if blocks and while loops that won't get
34 # compiled out.
35 my $foo = 42;
36 sub no_op { $foo++ }
37
38
39 $sch = {
40     'abc' => 1,
41     'def' => 2,
42     'jkl' => 3,
43 };
44
45 # basic normal array
46 $a = [];
47 $a->[0] = $sch;
48
49 eval {
50     $a->{'abc'} = 'ABC';
51 };
52 not_hash($@);
53
54 eval {
55     $a->{'def'} = 'DEF';
56 };
57 not_hash($@);
58
59 eval {
60     $a->{'jkl'} = 'JKL';
61 };
62 not_hash($@);
63
64 eval {
65     @keys = keys %$a;
66 };
67 not_hash($@);
68
69 eval {
70     @values = values %$a;
71 };
72 not_hash($@);
73
74 eval {
75     while( my($k,$v) = each %$a ) {
76         no_op;
77     }
78 };
79 not_hash($@);
80
81
82 # quick check with tied array
83 tie @fake, 'Tie::StdArray';
84 $a = \@fake;
85 $a->[0] = $sch;
86
87 eval {
88     $a->{'abc'} = 'ABC';
89 };
90 not_hash($@);
91
92 eval {
93     if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) }
94 };
95 not_hash($@);
96
97 # quick check with tied array
98 tie @fake, 'Tie::BasicArray';
99 $a = \@fake;
100 $a->[0] = $sch;
101
102 eval {
103     $a->{'abc'} = 'ABC';
104 };
105 not_hash($@);
106
107 eval {
108     if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) }
109 };
110 not_hash($@);
111
112 # quick check with tied array & tied hash
113 require Tie::Hash;
114 tie %fake, Tie::StdHash;
115 %fake = %$sch;
116 $a->[0] = \%fake;
117
118 eval {
119     $a->{'abc'} = 'ABC';
120 };
121 not_hash($@);
122
123 eval {
124     if ($a->{'abc'} eq 'ABC') { no_op(23) } else { no_op(42) }
125 };
126 not_hash($@);
127
128
129 # hash slice
130 eval {
131     my $slice = join('', 'x',@$a{'abc','def'},'x');
132 };
133 not_hash($@);
134
135
136 # evaluation in scalar context
137 my $avhv = [{}];
138
139 eval {
140     () = %$avhv;
141 };
142 not_hash($@);
143
144 push @$avhv, "a";
145 eval {
146     () = %$avhv;
147 };
148 not_hash($@);
149
150 $avhv = [];
151 eval { $a = %$avhv };
152 not_hash($@);
153
154 $avhv = [{foo=>1, bar=>2}];
155 eval {
156     %$avhv =~ m,^\d+/\d+,;
157 };
158 not_hash($@);
159
160 # check if defelem magic works
161 sub f {
162     print "not " unless $_[0] eq 'a';
163     $_[0] = 'b';
164     print "ok 11\n";
165 }
166 $a = [{key => 1}, 'a'];
167 eval {
168     f($a->{key});
169 };
170 not_hash($@);
171
172 # check if exists() is behaving properly
173 $avhv = [{foo=>1,bar=>2,pants=>3}];
174 eval {
175     no_op if exists $avhv->{bar};
176 };
177 not_hash($@);
178
179 eval {
180     $avhv->{pants} = undef;
181 };
182 not_hash($@);
183
184 eval {
185     no_op if exists $avhv->{pants};
186 };
187 not_hash($@);
188
189 eval {
190     no_op if exists $avhv->{bar};
191 };
192 not_hash($@);
193
194 eval {
195     $avhv->{bar} = 10;
196 };
197 not_hash($@);
198
199 eval {
200     no_op unless exists $avhv->{bar} and $avhv->{bar} == 10;
201 };
202 not_hash($@);
203
204 eval {
205     $v = delete $avhv->{bar};
206 };
207 not_hash($@);
208
209 eval {
210     no_op if exists $avhv->{bar};
211 };
212 not_hash($@);
213
214 eval {
215     $avhv->{foo} = 'xxx';
216 };
217 not_hash($@);
218 eval {
219     $avhv->{bar} = 'yyy';
220 };
221 not_hash($@);
222 eval {
223     $avhv->{pants} = 'zzz';
224 };
225 not_hash($@);
226 eval {
227     @x = delete @{$avhv}{'foo','pants'};
228 };
229 not_hash($@);
230 eval {
231     no_op unless "$avhv->{bar}" eq "yyy";
232 };
233 not_hash($@);
234
235 # hash assignment
236 eval {
237     %$avhv = ();
238 };
239 not_hash($@);
240
241 eval {
242     %hv = %$avhv;
243 };
244 not_hash($@);
245
246 eval {
247     %$avhv = (foo => 29, pants => 2, bar => 0);
248 };
249 not_hash($@);
250
251 my $extra;
252 my @extra;
253 eval {
254     ($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!");
255 };
256 not_hash($@);
257
258 eval {
259     %$avhv = ();
260     (%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!");
261 };
262 not_hash($@);
263
264 eval {
265     @extra = qw(whatever and stuff);
266     %$avhv = ();
267 };
268 not_hash($@);
269 eval {
270     (%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!");
271 };
272 not_hash($@);
273
274 eval {
275     (@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!");
276 };
277 not_hash($@);
278
279 # Check hash slices (BUG ID 20010423.002)
280 $avhv = [{foo=>1, bar=>2}];
281 eval {
282     @$avhv{"foo", "bar"} = (42, 53);
283 };
284 not_hash($@);