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