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