This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Use concat overloading for "foo$_->$*"
[perl5.git] / t / op / postfixderef.t
CommitLineData
2f6fc86f
DN
1#!./perl
2
3=head postfixderef
4
5this file contains all dereferencing tests from ref.t but using postfix instead of prefix or circumfix syntax.
6
7=cut
8
9
10
11BEGIN {
12 chdir 't' if -d 't';
13 @INC = qw(. ../lib);
1ae3d757 14 require './test.pl';
2f6fc86f
DN
15}
16
17use strict qw(refs subs);
18
c3492809 19plan(116);
2f6fc86f
DN
20
21{
22 no strict 'refs';
23# Test fake references.
24
25 $baz = "valid";
26 $bar = 'baz';
27 $foo = 'bar';
28 # is ($$$foo, 'valid');
29 is ($$foo->$*, 'valid');
30 is ($foo->$*->$*, 'valid');
31}
32
33# Test real references.
34
35$FOO = \$BAR;
36$BAR = \$BAZ;
37$BAZ = "hit";
38# is ($$$FOO, 'hit');
39is ($$FOO ->$*, 'hit');
40is ($FOO-> $* ->$*, 'hit');
41
42# Test references to real arrays.
43
44my $test = curr_test();
45@ary = ($test,$test+1,$test+2,$test+3);
46$ref[0] = \@a;
47$ref[1] = \@b;
48$ref[2] = \@c;
49$ref[3] = \@d;
50for $i (3,1,2,0) {
51 # push(@{$ref[$i]}, "ok $ary[$i]\n");
52 push($ref[$i]-> @*, "ok $ary[$i]\n");
53}
54print @a;
55#print ${$ref[1]}[0];
56#print @{$ref[2]}[0];
57print $ref[1]->[0];
58print $ref[2]->@[0];
59{
60 no strict 'refs';
61 print 'd'->@*; # print @{'d'};
62}
63curr_test($test+4);
64
65# Test references to references.
66
67$refref = \\$x;
68$x = "Good";
69is ($refref->$*->$*, 'Good'); # is ($$$refref, 'Good');
70
71
26321c2d 72# Test nested anonymous arrays.
2f6fc86f
DN
73
74$ref = [[],2,[3,4,5,]];
75is (scalar $ref->@*, 3); # is (scalar @$ref, 3);
76is ($ref->[1], 2); # is ($$ref[1], 2);
77# is (${$$ref[2]}[2], 5);
78is (${$ref->[2]}[2], 5);
79is ($ref->[2]->[2], 5);
80is ($ref->[2][2], 5);
81is (scalar $ref->[0]->@*, 0); # is (scalar @{$$ref[0]}, 0);
82
83is ($ref->[1], 2);
84is ($ref->[2]->[0], 3);
85
86# Test references to hashes of references.
87
88$refref = \%whatever;
89$refref->{"key"} = $ref;
90is ($refref->{"key"}->[2]->[0], 3);
91is ($refref->{"key"}->[2][0], 3);
92is ($refref->{"key"}[2]->[0], 3);
93is ($refref->{"key"}[2][0], 3);
94
95# Test to see if anonymous subarrays spring into existence.
96
97$spring[5]->[0] = 123;
98$spring[5]->[1] = 456;
99push($spring[5]->@*, 789); # push(@{$spring[5]}, 789);
100is (join(':',$spring[5]->@*), "123:456:789"); # is (join(':',@{$spring[5]}), "123:456:789");
101
102# Test to see if anonymous subhashes spring into existence.
103
104$spring2{"foo"}->@* = (1,2,3); # @{$spring2{"foo"}} = (1,2,3);
105$spring2{"foo"}->[3] = 4;
106is (join(':',$spring2{"foo"}->@*), "1:2:3:4");
107
108# Test references to subroutines.
109
110{
111 my $called;
112 sub mysub { $called++; }
113 local $subref = \&mysub;
114 &$subref;
115 is ($called, 1);
116 ok(eval '$subref->&*',"ampersand-star runs coderef: syntax");
117 is ($called, 2);
118 local *mysubalias;
119 ok(eval q{'mysubalias'->** = 'mysub'->**->*{CODE}}, "glob access syntax");
120 is ( eval 'mysubalias()', 2);
121 is($called, 3);
122
123}
124is ref eval {\&{""}}, "CODE", 'reference to &{""} [perl #94476]';
125
126# Test references to return values of operators (TARGs/PADTMPs)
127{
128 my @refs;
129 for("a", "b") {
130 push @refs, \"$_"
131 }
132 # is join(" ", map $$_, @refs), "a b", 'refgen+PADTMP';
133 is join(" ", map $_->$*, @refs), "a b", 'refgen+PADTMP';
134}
135
136$subrefref = \\&mysub2;
137is ($subrefref->$*->("GOOD"), "good"); # is ($$subrefref->("GOOD"), "good");
138sub mysub2 { lc shift }
139
140
141# Test anonymous hash syntax.
142
143$anonhash = {};
144is (ref $anonhash, 'HASH');
145$anonhash2 = {FOO => 'BAR', ABC => 'XYZ',};
146is (join('', sort values $anonhash2->%*), 'BARXYZ'); # is (join('', sort values %$anonhash2), 'BARXYZ');
ed3f8f87 147$anonhash2->{23} = 'tt';@$anonhash2{skiddoo=> 99} = qw/rr nn/;
2f6fc86f
DN
148is(join(':',$anonhash2->@{23 => skiddoo => 99}), 'tt:rr:nn', 'pf hash slice');
149
150# test immediate destruction of lexical objects (op/ref.t tests LIFO order)
151{ my $test = curr_test();
152my ($ScopeMark, $Stoogetime) = (1,$test);
153sub InScope() { $ScopeMark ? "ok " : "not ok " }
154sub shoulda::DESTROY { print InScope,$test++," - Larry\n"; }
155sub coulda::DESTROY { print InScope,$test++," - Curly\n"; }
156sub woulda::DESTROY { print InScope,$test++," - Moe\n"; }
157sub frieda::DESTROY { print InScope,$test++," - Shemp\n"; }
158sub spr::DESTROY { print InScope,$test++," - postfix scalar reference\n"; }
159sub apr::DESTROY { print InScope,$test++," - postfix array reference\n"; }
160sub hpr::DESTROY { print InScope,$test++," - postfix hash reference\n"; }
161
162{
163 no strict 'refs';
164 # and real references taken from symbolic postfix dereferences
165 local ($joe, @curly, %larry, $momo);
166 my ($s,@a,%h);
167 my $woulda = bless \'joe'->$*, 'woulda';
168 my $frieda = bless \'momo'->$*, 'frieda';
169 my $coulda = eval q{bless \'curly'->@*, 'coulda' } or print "# $@","not ok ",$test++,"\n";
170 my $shoulda = eval q{bless \'larry'->%*, 'shoulda'} or print "# $@","not ok ",$test++,"\n";
171# print "# postfix whack-star instead of prefix whack\n";
172# my $spr = eval q/ bless $s->\* , "spr"/; $@ and print "# $@","not ok ",$test++,"\n";
173# my $apr = eval q/ bless @a->\* , 'apr'/; $@ and print "# $@","not ok ",$test++,"\n";
174# my $hpr = eval q/ bless %h->\* , 'hpr'/; $@ and print "# $@","not ok ",$test++,"\n";
175 print "# leaving block: we want (larry, curly, moe, shemp)\n";
176}
177
178print "# left block\n";
179$ScopeMark = 0;
180curr_test($test);
181is ($test, $Stoogetime + 4, "no stooges outlast their scope");
182}
183
184{
185 no strict 'refs';
186 $name8 = chr 163;
187 $name_utf8 = $name8 . chr 256;
188 chop $name_utf8;
189
190# is ($$name8, undef, 'Nothing before we start');
191# is ($$name_utf8, undef, 'Nothing before we start');
192# $$name8 = "Pound";
193# is ($$name8, "Pound", 'Accessing via 8 bit symref works');
194# is ($$name_utf8, "Pound", 'Accessing via UTF8 symref works');
195
196 is ($name8->$*, undef, 'Nothing before we start');
197 is ($name_utf8->$*, undef, 'Nothing before we start');
198 $name8->$* = "Pound";
199 is ($name8->$*, "Pound", 'Accessing via 8 bit symref works');
200 is ($name_utf8->$*, "Pound", 'Accessing via UTF8 symref works');
201}
202
203{
204 no strict 'refs';
205 $name_utf8 = $name = chr 9787;
206 utf8::encode $name_utf8;
207
208 is (length $name, 1, "Name is 1 char");
209 is (length $name_utf8, 3, "UTF8 representation is 3 chars");
210
ed3f8f87
FC
211 is ($name->$*, undef, 'Nothing before we start');
212 is ($name_utf8->$*, undef, 'Nothing before we start');
2f6fc86f
DN
213 $name->$* = "Face";
214 is ($name->$*, "Face", 'Accessing via Unicode symref works');
215 is ($name_utf8->$*, undef,
216 'Accessing via the UTF8 byte sequence still gives nothing');
217}
218
219{
220 no strict 'refs';
221 $name1 = "\0Chalk";
222 $name2 = "\0Cheese";
223
224 is ($ $name1, undef, 'Nothing before we start (scalars)');
225 is ($name2 -> $* , undef, 'Nothing before we start');
226 $name1 ->$* = "Yummy";
227 is ($name1-> $*, "Yummy", 'Accessing via the correct name works');
228 is ($$name2, undef,
229 'Accessing via a different NUL-containing name gives nothing');
230 # defined uses a different code path
231 ok (defined $name1->$*, 'defined via the correct name works');
232 ok (!defined $name2->$*,
233 'defined via a different NUL-containing name gives nothing');
234
235 my (undef, $one) = $name1 ->@[2,3];
236 my (undef, $two) = $name2-> @[2,3];
237 is ($one, undef, 'Nothing before we start (array slices)');
238 is ($two, undef, 'Nothing before we start');
239 $name1->@[2,3] = ("Very", "Yummy");
240 (undef, $one) = $name1 -> @[2,3];
241 (undef, $two) = $name2 -> @[2,3];
242 is ($one, "Yummy", 'Accessing via the correct name works');
243 is ($two, undef,
244 'Accessing via a different NUL-containing name gives nothing');
245 ok (defined $one, 'defined via the correct name works');
246 ok (!defined $two,
247 'defined via a different NUL-containing name gives nothing');
248
249}
250
251
252# test dereferencing errors
253{
254 format STDERR =
255.
256 my $ref;
257 foreach $ref (*STDOUT{IO}, *STDERR{FORMAT}) {
258 eval q/ $ref->$* /;
259 like($@, qr/Not a SCALAR reference/, "Scalar dereference");
260 eval q/ $ref->@* /;
261 like($@, qr/Not an ARRAY reference/, "Array dereference");
262 eval q/ $ref->%* /;
263 like($@, qr/Not a HASH reference/, "Hash dereference");
264 eval q/ $ref->() /;
265 like($@, qr/Not a CODE reference/, "Code dereference");
266 }
267
268 $ref = *STDERR{FORMAT};
269 eval q/ $ref->** /; # postfix GLOB dereference ?
270 like($@, qr/Not a GLOB reference/, "Glob dereference");
271
272 $ref = *STDOUT{IO};
273 eval q/ $ref->** /;
274 is($@, '', "Glob dereference of PVIO is acceptable");
275
ed3f8f87 276 is($ref, (eval '$ref->*{IO}'), "IO slot of the temporary glob is set correctly");
2f6fc86f
DN
277}
278
279# these will segfault if they fail
280sub PVBM () { 'foo' }
281my $pvbm_r;
282ok(eval q/ $pvbm_r = \'PVBM'->&* /, "postfix symref to sub name");
283is("$pvbm_r", "".\&PVBM, "postfix and prefix mechanisms provide same result");
284my $pvbm = PVBM;
285my $rpvbm = \$pvbm;
286{
287my $SynCtr;
288ok (!eval q{ $SynCtr++; $rpvbm->** }, 'PVBM ref is not a GLOB ref');
289ok (!eval q{ $SynCtr++; $pvbm->** }, 'PVBM is not a GLOB ref');
290is ($SynCtr, 2, "starstar GLOB postderef parses");
291}
292ok (!eval { $pvbm->$* }, 'PVBM is not a SCALAR ref');
293ok (!eval { $pvbm->@* }, 'PVBM is not an ARRAY ref');
294ok (!eval { $pvbm->%* }, 'PVBM is not a HASH ref');
295
296# Test undefined hash references as arguments to %{} in boolean context
297# [perl #81750]
298{
299 no strict 'refs';
300 eval { my $foo; $foo->%*; }; ok !$@, '%$undef';
301 eval { my $foo; scalar $foo->%*; }; ok !$@, 'scalar %$undef';
302 eval { my $foo; !$foo->%*; }; ok !$@, '!%$undef';
303 eval { my $foo; if ( $foo->%*) {} }; ok !$@, 'if ( %$undef) {}';
304 eval { my $foo; if (!$foo->%*) {} }; ok !$@, 'if (!%$undef) {}';
305 eval { my $foo; unless ( $foo->%*) {} }; ok !$@, 'unless ( %$undef) {}';
306 eval { my $foo; unless (!$foo->%*) {} }; ok !$@, 'unless (!%$undef) {}';
307 eval { my $foo; 1 if $foo->%*; }; ok !$@, '1 if %$undef';
308 eval { my $foo; 1 if !$foo->%*; }; ok !$@, '1 if !%$undef';
309 eval { my $foo; 1 unless $foo->%*; }; ok !$@, '1 unless %$undef;';
310 eval { my $foo; 1 unless ! $foo->%*; }; ok !$@, '1 unless ! %$undef';
311 eval { my $foo; $foo->%* ? 1 : 0; }; ok !$@, ' %$undef ? 1 : 0';
312 eval { my $foo; !$foo->%* ? 1 : 0; }; ok !$@, '!%$undef ? 1 : 0';
313}
314
76eba8ab
FC
315# Postfix key/value slices
316is join(" ", {1..10}->%{1, 7, 3}), "1 2 7 8 3 4", '->%{';
317is join(" ", ['a'..'z']->%[1, 7, 3]), "1 b 7 h 3 d", '->%[';
2f6fc86f 318
ff25e5db
FC
319# Array length
320is [1..10]->$#*, 9, 'rvalue ->$#*';
321@foo = 1..10;
322(\@foo)->$#*--;
323is "@foo", "1 2 3 4 5 6 7 8 9", 'lvalue ->$#*';
324
cc624add
FC
325# Interpolation
326$_ = "foo";
327@foo = 7..9;
328%foo = qw( foo oof );
329{
330 no warnings 'deprecated';
331 $* = 42;
332 is "$_->$*", 'foo->42', '->$* interpolation without feature';
ff25e5db
FC
333 $# = 43;
334 is "$_->$#*", 'foo->43*', '->$#* interpolation without feature';
cc624add
FC
335}
336is "$_->@*", 'foo->@*', '->@* does not interpolate without feature';
337is "$_->@[0]", 'foo->@[0]', '->@[ does not interpolate without feature';
338is "$_->@{foo}", "foo->7 8 9", '->@{ does not interpolate without feature';
339{
340 use feature 'postderef_qq';
341 no strict 'refs';
342 $foo = 43;
343 is "$_->$*", "43", '->$* interpolated';
ff25e5db 344 is "$_->$#*", "2", '->$#* interpolated';
cc624add
FC
345 is "$_->@*", "7 8 9", '->@* interpolated';
346 is "$_->@[0,1]", "7 8", '->@[ interpolated';
347 is "$_->@{foo}", "oof", '->@{ interpolated';
348 is "foo$_->$*bar", "foo43bar", '->$* interpolated w/other stuff';
349 is "foo$_->@*bar", "foo7 8 9bar", '->@* interpolated w/other stuff';
350 is "foo$_->@[0,1]bar", "foo7 8bar", '->@[ interpolated w/other stuff';
351 is "foo$_->@{foo}bar", "foooofbar", '->@{ interpolated w/other stuff';
760ca746
FC
352 is "@{[foo->@*]}", "7 8 9", '->@* inside "@{...}"';
353 is "@{[foo->@[0,1]]}", "7 8", '->@[ inside "@{...}"';
354 is "@{[foo->@{foo}]}", "oof", '->@{ inside "@{...}"';
c3492809
FC
355
356 # "foo $_->$*" should be equivalent to "foo $$_", which uses concat
357 # overloading
358 package o {
359 use overload fallback=>1,
360 '""' => sub { $_[0][0] },
361 '.' => sub { bless [ "$_[$_[2]]"." plus "."$_[!$_[2]]" ] };
362 }
363 my $o = bless ["overload"], o::;
364 my $ref = \$o;
365 is "foo$ref->$*bar", "foo plus overload plus bar",
366 '"foo $s->$* bar" does concat overloading';
cc624add 367}