Bump Devel::PPPort to 3.44 for CPAN release
[perl.git] / t / op / kvaslice.t
1 #!./perl -w
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     set_up_inc('../lib');
7 }
8
9 # use strict;
10
11 plan tests => 38;
12
13 # simple use cases
14 {
15     my @a = 'a'..'z';
16
17     is( join(':', %a[0,1,2]), '0:a:1:b:2:c', "correct result and order");
18     is( join(':', %a[2,1,0]), '2:c:1:b:0:a', "correct result and order");
19     is( join(':', %a[1,0,2]), '1:b:0:a:2:c', "correct result and order");
20
21     ok( eq_hash( { %a[5,6] }, { 5 => 'f', 6 => 'g' } ), "correct hash" );
22
23     is( join(':', %a[()]), '', "correct result for empty slice");
24 }
25
26 # not existing elements
27 {
28     my @a = 'a'..'d';
29     ok( eq_hash( { %a[3..4] }, { 3 => 'd', 4 => undef } ),
30         "not existing returned with undef value" );
31
32     ok( !exists $a[5], "no autovivification" );
33 }
34
35 # repeated keys
36 {
37     my @a = 'a'..'d';
38     @a = %a[ (1) x 3 ];
39     ok eq_array( \@a, [ (1 => 'b') x 3 ]), "repetead keys end with repeated results";
40 }
41
42 # scalar context
43 {
44     my @warn;
45     local $SIG{__WARN__} = sub {push @warn, "@_"};
46
47     my @a = 'a'..'z';
48     is eval'scalar %a[4,5,6]', 'g', 'last element in scalar context';
49
50     like ($warn[0],
51      qr/^\%a\[\.\.\.\] in scalar context better written as \$a\[\.\.\.\]/);
52
53     eval 'is( scalar %a[5], "f", "correct value");';
54
55     is (scalar @warn, 2);
56     like ($warn[1], qr/^\%a\[5\] in scalar context better written as \$a\[5\]/);
57 }
58
59 # autovivification
60 {
61     my @a = 'a'..'b';
62
63     my @t = %a[1,2];
64     is( join(':', map {$_//'undef'} @t), '1:b:2:undef', "correct result");
65     ok( eq_array( \@a, ['a', 'b'] ), "correct array" );
66 }
67
68 # refs
69 {
70     my $a = [ 'a'..'z' ];
71
72     is( join(':', %$a[2,3,4]), '2:c:3:d:4:e', "correct result and order");
73     is( join(':', %{$a}[2,3,4]), '2:c:3:d:4:e', "correct result and order");
74 }
75
76 # no interpolation
77 {
78     my @a = 'a'..'b';
79     is( "%a[1,2]", q{%a[1,2]}, 'no interpolation within strings' );
80 }
81
82 # ref of a slice produces list
83 {
84     my @a = 'a'..'z';
85     my @tmp = \%a[2,3,4];
86
87     my $ok = 1;
88     $ok = 0 if grep !ref, @tmp;
89     ok $ok, "all elements are refs";
90
91     is join( ':', map{ $$_ } @tmp ), '2:c:3:d:4:e';
92 }
93
94 # lvalue usage in foreach
95 {
96     my @a = qw(0 1 2 3);
97     my @i = (1,3);
98     $_++ foreach %a[@i];
99     ok( eq_array( \@a, [0,2,2,4] ), "correct array" );
100     ok( eq_array( \@i, [1,3] ), "indexes not touched" );
101 }
102
103 # lvalue subs in foreach
104 {
105     my @a = qw(0 1 2 3);
106     my @i = (1,3);
107     sub foo:lvalue{ %a[@i] };
108     $_++ foreach foo();
109     ok( eq_array( \@a, [0,2,2,4] ), "correct array" );
110     ok( eq_array( \@i, [1,3] ), "indexes not touched" );
111 }
112
113 # errors
114 {
115     my @a = 'a'..'b';
116     # no local
117     {
118         local $@;
119         eval 'local %a[1,2]';
120         like $@, qr{^Can't modify index/value array slice in local at},
121             'local dies';
122     }
123     # no assign
124     {
125         local $@;
126         eval '%a[1,2] = qw(B A)';
127         like $@, qr{^Can't modify index/value array slice in list assignment},
128             'assign dies';
129     }
130     # lvalue subs in assignment
131     {
132         local $@;
133         eval 'sub bar:lvalue{ %a[1,2] }; bar() = "1"';
134         like $@, qr{^Can't modify index/value array slice in list assignment},
135             'not allowed as result of lvalue sub';
136     }
137 }
138
139 # warnings
140 {
141     my @warn;
142     local $SIG{__WARN__} = sub {push @warn, "@_"};
143
144     my @a = 'a'..'c';
145     {
146         @warn = ();
147         my $v = eval '%a[0]';
148         is (scalar @warn, 1, 'warning in scalar context');
149         like $warn[0],
150              qr{^%a\[0\] in scalar context better written as \$a\[0\]},
151             "correct warning text";
152     }
153     {
154         @warn = ();
155         my ($k,$v) = eval '%a[0]';
156         is ($k, 0);
157         is ($v, 'a');
158         is (scalar @warn, 0, 'no warning in list context');
159     }
160 }
161
162 # simple case with tied
163 {
164     require Tie::Array;
165     tie my @a, 'Tie::StdArray';
166     @a = 'a'..'c';
167
168     ok( eq_array( [%a[1,2, 3]], [qw(1 b 2 c 3), undef] ),
169         "works on tied" );
170
171     ok( !exists $a[3], "no autovivification" );
172 }
173
174 # keys/value/each refuse to compile kvaslice
175 {
176     my %h = 'a'..'b';
177     my @i = \%h;
178     eval '() = keys %i[(0)]';
179     like($@, qr/Experimental keys on scalar is now forbidden/,
180          'keys %array[ix] forbidden');
181     eval '() = values %i[(0)]';
182     like($@, qr/Experimental values on scalar is now forbidden/,
183          'values %array[ix] forbidden');
184     eval '() = each %i[(0)]';
185     like($@, qr/Experimental each on scalar is now forbidden/,
186          'each %array[ix] forbidden');
187 }
188
189 # \% prototype expects hash deref
190 sub nowt_but_hash(\%) {}
191 eval 'nowt_but_hash %_[0]';
192 like $@, qr`^Type of arg 1 to main::nowt_but_hash must be hash \(not(?x:
193            ) index/value array slice\) at `,
194     '\% prototype';