xref: /openbsd/gnu/usr.bin/perl/t/op/multideref.t (revision 6f40fd34) 
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
21plan 58;
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}
188
189# RT #123609
190# don't evaluate a const array index unless it's really a const array
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}
208