Bump Devel::PPPort to 3.44 for CPAN release
[perl.git] / t / op / postfixderef.t
1 #!./perl
2
3 =head postfixderef
4
5 this file contains all dereferencing tests from ref.t but using postfix instead of prefix or circumfix syntax.
6
7 =cut
8
9
10
11 BEGIN {
12     chdir 't' if -d 't';
13     require './test.pl';
14     set_up_inc(qw(. ../lib));
15 }
16
17 use strict qw(refs subs);
18
19 plan(128);
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');
39 is ($$FOO ->$*, 'hit');
40 is ($FOO-> $* ->$*, 'hit');
41
42 # Test references to real arrays.
43
44 my $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;
50 for $i (3,1,2,0) {
51     # push(@{$ref[$i]}, "ok $ary[$i]\n");
52     push($ref[$i]-> @*, "ok $ary[$i]\n");
53 }
54 print @a;
55 #print ${$ref[1]}[0];
56 #print @{$ref[2]}[0];
57 print $ref[1]->[0];
58 print $ref[2]->@[0];
59 {
60     no strict 'refs';
61     print 'd'->@*; # print @{'d'};
62 }
63 curr_test($test+4);
64
65 # Test references to references.
66
67 $refref = \\$x;
68 $x = "Good";
69 is ($refref->$*->$*, 'Good'); # is ($$$refref, 'Good');
70
71
72 # Test nested anonymous arrays.
73
74 $ref = [[],2,[3,4,5,]];
75 is (scalar $ref->@*, 3); # is (scalar @$ref, 3);
76 is ($ref->[1], 2); # is ($$ref[1], 2);
77 # is (${$$ref[2]}[2], 5);
78 is (${$ref->[2]}[2], 5);
79 is ($ref->[2]->[2], 5);
80 is ($ref->[2][2], 5);
81 is  (scalar $ref->[0]->@*, 0); # is (scalar @{$$ref[0]}, 0);
82
83 is ($ref->[1], 2);
84 is ($ref->[2]->[0], 3);
85
86 # Test references to hashes of references.
87
88 $refref = \%whatever;
89 $refref->{"key"} = $ref;
90 is ($refref->{"key"}->[2]->[0], 3);
91 is ($refref->{"key"}->[2][0], 3);
92 is ($refref->{"key"}[2]->[0], 3);
93 is ($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;
99 push($spring[5]->@*, 789); # push(@{$spring[5]}, 789);
100 is (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;
106 is (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 }
124 is 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;
137 is ($subrefref->$*->("GOOD"), "good"); # is ($$subrefref->("GOOD"), "good");
138 sub mysub2 { lc shift }
139
140
141 # Test anonymous hash syntax.
142
143 $anonhash = {};
144 is (ref $anonhash, 'HASH');
145 $anonhash2 = {FOO => 'BAR', ABC => 'XYZ',};
146 is (join('', sort values $anonhash2->%*), 'BARXYZ'); # is (join('', sort values %$anonhash2), 'BARXYZ');
147 $anonhash2->{23} = 'tt';@$anonhash2{skiddoo=> 99} = qw/rr nn/;
148 is(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();
152 my ($ScopeMark, $Stoogetime) = (1,$test);
153 sub InScope() { $ScopeMark ? "ok " : "not ok " }
154 sub shoulda::DESTROY  { print InScope,$test++," - Larry\n"; }
155 sub coulda::DESTROY   { print InScope,$test++," - Curly\n"; }
156 sub woulda::DESTROY   { print InScope,$test++," - Moe\n"; }
157 sub frieda::DESTROY   { print InScope,$test++," - Shemp\n"; }
158 sub spr::DESTROY   { print InScope,$test++," - postfix scalar reference\n"; }
159 sub apr::DESTROY   { print InScope,$test++," - postfix array reference\n"; }
160 sub 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
178 print "# left block\n";
179 $ScopeMark = 0;
180 curr_test($test);
181 is ($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
211     is ($name->$*, undef, 'Nothing before we start');
212     is ($name_utf8->$*, undef, 'Nothing before we start');
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
276     is($ref, (eval '$ref->*{IO}'), "IO slot of the temporary glob is set correctly");
277 }
278
279 # these will segfault if they fail
280 sub PVBM () { 'foo' }
281 my $pvbm_r;
282 ok(eval q/ $pvbm_r = \'PVBM'->&* /, "postfix symref to sub name");
283 is("$pvbm_r", "".\&PVBM, "postfix and prefix mechanisms provide same result");
284 my $pvbm = PVBM;
285 my $rpvbm = \$pvbm;
286 {
287 my $SynCtr;
288 ok (!eval q{ $SynCtr++; $rpvbm->** }, 'PVBM ref is not a GLOB ref');
289 ok (!eval q{ $SynCtr++; $pvbm->** }, 'PVBM is not a GLOB ref');
290 is ($SynCtr, 2, "starstar GLOB postderef parses");
291 }
292 ok (!eval { $pvbm->$* }, 'PVBM is not a SCALAR ref');
293 ok (!eval { $pvbm->@* }, 'PVBM is not an ARRAY ref');
294 ok (!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
315 # Postfix key/value slices
316 is join(" ", {1..10}->%{1, 7, 3}), "1 2 7 8 3 4", '->%{';
317 is join(" ", ['a'..'z']->%[1, 7, 3]), "1 b 7 h 3 d", '->%[';
318
319 # Array length
320 is [1..10]->$#*, 9, 'rvalue ->$#*';
321 @foo = 1..10;
322 (\@foo)->$#*--;
323 is "@foo", "1 2 3 4 5 6 7 8 9", 'lvalue ->$#*';
324
325 # Interpolation
326 $_ = "foo";
327 @foo = 7..9;
328 %foo = qw( foo oof );
329 is "$_->@*", 'foo->@*', '->@* does not interpolate without feature';
330 is "$_->@[0]", 'foo->@[0]', '->@[ does not interpolate without feature';
331 is "$_->@{foo}", "foo->7 8 9", '->@{ does not interpolate without feature';
332 {
333     use feature 'postderef_qq';
334     no strict 'refs';
335     $foo = 43;
336     is "$_->$*", "43", '->$* interpolated';
337     is "$_->$#*", "2", '->$#* interpolated';
338     is "$_->@*", "7 8 9", '->@* interpolated';
339     is "$_->@[0,1]", "7 8", '->@[ interpolated';
340     is "$_->@{foo}", "oof", '->@{ interpolated';
341     is "foo$_->$*bar", "foo43bar", '->$* interpolated w/other stuff';
342     is "foo$_->@*bar", "foo7 8 9bar", '->@* interpolated w/other stuff';
343     is "foo$_->@[0,1]bar", "foo7 8bar", '->@[ interpolated w/other stuff';
344     is "foo$_->@{foo}bar", "foooofbar", '->@{ interpolated w/other stuff';
345     is "@{[foo->@*]}", "7 8 9", '->@* inside "@{...}"';
346     is "@{[foo->@[0,1]]}", "7 8", '->@[ inside "@{...}"';
347     is "@{[foo->@{foo}]}", "oof", '->@{ inside "@{...}"';
348
349     # "foo $_->$*" should be equivalent to "foo $$_", which uses concat
350     # overloading
351     package o {
352         use overload fallback=>1,
353             '""' => sub { $_[0][0] },
354             '.'  => sub { bless [ "$_[$_[2]]"." plus "."$_[!$_[2]]" ] };
355     }
356     my $o = bless ["overload"], o::;
357     my $ref = \$o;
358     is "foo$ref->$*bar", "foo plus overload plus bar",
359        '"foo $s->$* bar" does concat overloading';
360 }
361
362 # parsing of {} subscript as subscript rather than block
363 {
364     sub ppp { "qqq" }
365     my $h = { ppp => "pp", qqq => "qq", rrr => 7 };
366     is ${$h}{ppp}, "pp";
367     is ${$h}{"rrr"} - 2, 5;
368     my $ar = [$h];
369     is $ar->[0]->{ppp}, "pp";
370     is $ar->[0]->{"rrr"} - 2, 5;
371     is $ar->[0]{ppp}, "pp";
372     is $ar->[0]{"rrr"} - 2, 5;
373     my $hr = {h=>$h};
374     is $hr->{"h"}->{ppp}, "pp";
375     is $hr->{"h"}->{"rrr"} - 2, 5;
376     is $hr->{"h"}{ppp}, "pp";
377     is $hr->{"h"}{"rrr"} - 2, 5;
378     my $cr = sub { $h };
379     is $cr->()->{ppp}, "pp";
380     is $cr->()->{"rrr"} - 2, 5;
381     is $cr->(){ppp}, "pp";
382     is $cr->(){"rrr"} - 2, 5;
383 }