This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pp_multideref: tweak an assertion
[perl5.git] / t / op / multideref.t
CommitLineData
fedf30e1
DM
1#!./perl
2#
3# test OP_MULTIDEREF.
4#
5# This optimising op is used when one or more array or hash aggregate
6# lookups / derefs are performed, and where each key/index is a simple
7# constant or scalar var; e.g.
8#
9# $r->{foo}[0]{$k}[$i]
10
11
12BEGIN {
13 chdir 't';
14 require './test.pl';
15 set_up_inc("../lib");
16}
17
18use warnings;
19use strict;
20
d8f2fe09 21plan 62;
fedf30e1
DM
22
23
24# check that strict refs hint is handled
25
26{
27 package strict_refs;
28
29 our %foo;
30 my @a = ('foo');
31 eval {
32 $a[0]{k} = 7;
33 };
34 ::like($@, qr/Can't use string/, "strict refs");
35 ::ok(!exists $foo{k}, "strict refs, not exist");
36
37 no strict 'refs';
38
39 $a[0]{k} = 13;
40 ::is($foo{k}, 13, "no strict refs, exist");
41}
42
43# check the basics of multilevel lookups
44
45{
46 package basic;
47
48 # build up the multi-level structure piecemeal to try and avoid
49 # relying on what we're testing
50
51 my @a;
52 my $r = \@a;
53 my $rh = {};
54 my $ra = [];
55 my %h = qw(a 1 b 2 c 3 d 4 e 5 f 6);
56 push @a, 66, 77, 'abc', $rh;
57 %$rh = (foo => $ra, bar => 'BAR');
58 push @$ra, 'def', \%h;
59
60 our ($i1, $i2, $k1, $k2) = (3, 1, 'foo', 'c');
61 my ($li1, $li2, $lk1, $lk2) = (3, 1, 'foo', 'c');
62 my $z = 0;
63
64 # fetch
65
66 ::is($a[3]{foo}[1]{c}, 3, 'fetch: const indices');
67 ::is($a[$i1]{$k1}[$i2]{$k2}, 3, 'fetch: pkg indices');
68 ::is($r->[$i1]{$k1}[$i2]{$k2}, 3, 'fetch: deref pkg indices');
69 ::is($a[$li1]{$lk1}[$li2]{$lk2}, 3, 'fetch: lexical indices');
70 ::is($r->[$li1]{$lk1}[$li2]{$lk2}, 3, 'fetch: deref lexical indices');
71 ::is(($r//0)->[$li1]{$lk1}[$li2+$z]{$lk2}, 3,
72 'fetch: general expression and index');
73
74
75 # store
76
77 ::is($a[3]{foo}[1]{c} = 5, 5, 'store: const indices');
78 ::is($a[3]{foo}[1]{c}, 5, 'store: const indices 2');
79 ::is($a[$i1]{$k1}[$i2]{$k2} = 7, 7, 'store: pkg indices');
80 ::is($a[$i1]{$k1}[$i2]{$k2}, 7, 'store: pkg indices 2');
81 ::is($r->[$i1]{$k1}[$i2]{$k2} = 9, 9, 'store: deref pkg indices');
82 ::is($r->[$i1]{$k1}[$i2]{$k2}, 9, 'store: deref pkg indices 2');
83 ::is($a[$li1]{$lk1}[$li2]{$lk2} = 11, 11, 'store: lexical indices');
84 ::is($a[$li1]{$lk1}[$li2]{$lk2}, 11, 'store: lexical indices 2');
85 ::is($r->[$li1]{$lk1}[$li2]{$lk2} = 13, 13, 'store: deref lexical indices');
86 ::is($r->[$li1]{$lk1}[$li2]{$lk2}, 13, 'store: deref lexical indices 2');
87 ::is(($r//0)->[$li1]{$lk1}[$li2+$z]{$lk2} = 15, 15,
88 'store: general expression and index');
89 ::is(($r//0)->[$li1]{$lk1}[$li2+$z]{$lk2}, 15,
90 'store: general expression and index 2');
91
92
93 # local
94
95 {
96 ::is(local $a[3]{foo}[1]{c} = 19, 19, 'local const indices');
97 ::is($a[3]{foo}[1]{c}, 19, 'local const indices 2');
98 }
99 ::is($a[3]{foo}[1]{c}, 15, 'local const indices 3');
100 {
101 ::is(local $a[$i1]{$k1}[$i2]{$k2} = 21, 21, 'local pkg indices');
102 ::is($a[$i1]{$k1}[$i2]{$k2}, 21, 'local pkg indices 2');
103 }
104 ::is($a[$i1]{$k1}[$i2]{$k2}, 15, 'local pkg indices 3');
105 {
106 ::is(local $a[$li1]{$lk1}[$li2]{$lk2} = 23, 23, 'local lexical indices');
107 ::is($a[$li1]{$lk1}[$li2]{$lk2}, 23, 'local lexical indices 2');
108 }
109 ::is($a[$li1]{$lk1}[$li2]{$lk2}, 15, 'local lexical indices 3');
110 {
111 ::is(local+($r//0)->[$li1]{$lk1}[$li2+$z]{$lk2} = 25, 25,
112 'local general');
113 ::is(($r//0)->[$li1]{$lk1}[$li2+$z]{$lk2}, 25, 'local general 2');
114 }
115 ::is(($r//0)->[$li1]{$lk1}[$li2+$z]{$lk2}, 15, 'local general 3');
116
117
118 # exists
119
120 ::ok(exists $a[3]{foo}[1]{c}, 'exists: const indices');
121 ::ok(exists $a[$i1]{$k1}[$i2]{$k2}, 'exists: pkg indices');
122 ::ok(exists $r->[$i1]{$k1}[$i2]{$k2}, 'exists: deref pkg indices');
123 ::ok(exists $a[$li1]{$lk1}[$li2]{$lk2}, 'exists: lexical indices');
124 ::ok(exists $r->[$li1]{$lk1}[$li2]{$lk2}, 'exists: deref lexical indices');
125 ::ok(exists +($r//0)->[$li1]{$lk1}[$li2+$z]{$lk2}, 'exists: general');
126
127 # delete
128
129 our $k3 = 'a';
130 my $lk4 = 'b';
131 ::is(delete $a[3]{foo}[1]{c}, 15, 'delete: const indices');
132 ::is(delete $a[$i1]{$k1}[$i2]{$k3}, 1, 'delete: pkg indices');
133 ::is(delete $r->[$i1]{$k1}[$i2]{d}, 4, 'delete: deref pkg indices');
134 ::is(delete $a[$li1]{$lk1}[$li2]{$lk4}, 2, 'delete: lexical indices');
135 ::is(delete $r->[$li1]{$lk1}[$li2]{e}, 5, 'delete: deref lexical indices');
136 ::is(delete +($r//0)->[$li1]{$lk1}[$li2+$z]{f}, 6, 'delete: general');
137
138 # !exists
139
140 ::ok(!exists $a[3]{foo}[1]{c}, '!exists: const indices');
141 ::ok(!exists $a[$i1]{$k1}[$i2]{$k3}, '!exists: pkg indices');
142 ::ok(!exists $r->[$i1]{$k1}[$i2]{$k3}, '!exists: deref pkg indices');
143 ::ok(!exists $a[$li1]{$lk1}[$li2]{$lk4}, '!exists: lexical indices');
144 ::ok(!exists $r->[$li1]{$lk1}[$li2]{$lk4},'!exists: deref lexical indices');
145 ::ok(!exists +($r//0)->[$li1]{$lk1}[$li2+$z]{$lk4},'!exists: general');
146}
147
148
149# weird "constant" keys
150
151{
152 use constant my_undef => undef;
153 use constant my_ref => [];
154 no warnings 'uninitialized';
155 my %h1;
156 $h1{+my_undef} = 1;
157 is(join(':', keys %h1), '', "+my_undef");
158 my %h2;
159 $h2{+my_ref} = 1;
160 like(join(':', keys %h2), qr/x/, "+my_ref");
161}
162
163
164
165{
166 # test that multideref is marked OA_DANGEROUS, i.e. its one of the ops
167 # that should set the OPpASSIGN_COMMON flag in list assignments
168
169 my $x = {};
170 $x->{a} = [ 1 ];
171 $x->{b} = [ 2 ];
172 ($x->{a}, $x->{b}) = ($x->{b}, $x->{a});
173 is($x->{a}[0], 2, "OA_DANGEROUS a");
174 is($x->{b}[0], 1, "OA_DANGEROUS b");
175}
176
177# defer
178
179
180sub defer {}
181
182{
183 my %h;
184 $h{foo} = {};
185 defer($h{foo}{bar});
186 ok(!exists $h{foo}{bar}, "defer");
187}
290c8850
DM
188
189# RT #123609
04ffa453 190# don't evaluate a const array index unless it's really a const array
290c8850
DM
191# index
192
193{
194 my $warn = '';
195 local $SIG{__WARN__} = sub { $warn .= $_[0] };
196 ok(
197 eval q{
198 my @a = (1);
199 my $arg = 0;
200 my $x = $a[ 'foo' eq $arg ? 1 : 0 ];
201 1;
202 },
203 "#123609: eval"
204 )
205 or diag("eval gave: $@");
206 is($warn, "", "#123609: warn");
207}
43dbb3c1
DM
208
209# RT #130727
210# a [ah]elem op can be both OPpLVAL_INTRO and OPpDEREF. It may not make
211# much sense, but it shouldn't fail an assert.
212
213{
214 my @x;
215 eval { @{local $x[0][0]} = 1; };
216 like $@, qr/Can't use an undefined value as an ARRAY reference/,
217 "RT #130727 error";
218 ok !defined $x[0][0],"RT #130727 array not autovivified";
d8f2fe09
DM
219
220 eval { @{1, local $x[0][0]} = 1; };
221 like $@, qr/Can't use an undefined value as an ARRAY reference/,
222 "RT #130727 part 2: error";
223 ok !defined $x[0][0],"RT #130727 part 2: array not autovivified";
224
43dbb3c1 225}