Commit | Line | Data |
---|---|---|
2f6fc86f DN |
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 | @INC = qw(. ../lib); | |
14 | require 'test.pl'; | |
15 | } | |
16 | ||
17 | use strict qw(refs subs); | |
18 | ||
ff25e5db | 19 | plan(125); |
eae81d97 FC |
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 | ||
45 | use feature 'postderef'; | |
1f25714a | 46 | no warnings 'experimental::postderef'; |
2f6fc86f DN |
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'); | |
66 | is ($$FOO ->$*, 'hit'); | |
67 | is ($FOO-> $* ->$*, 'hit'); | |
68 | ||
69 | # Test references to real arrays. | |
70 | ||
71 | my $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; | |
77 | for $i (3,1,2,0) { | |
78 | # push(@{$ref[$i]}, "ok $ary[$i]\n"); | |
79 | push($ref[$i]-> @*, "ok $ary[$i]\n"); | |
80 | } | |
81 | print @a; | |
82 | #print ${$ref[1]}[0]; | |
83 | #print @{$ref[2]}[0]; | |
84 | print $ref[1]->[0]; | |
85 | print $ref[2]->@[0]; | |
86 | { | |
87 | no strict 'refs'; | |
88 | print 'd'->@*; # print @{'d'}; | |
89 | } | |
90 | curr_test($test+4); | |
91 | ||
92 | # Test references to references. | |
93 | ||
94 | $refref = \\$x; | |
95 | $x = "Good"; | |
96 | is ($refref->$*->$*, 'Good'); # is ($$$refref, 'Good'); | |
97 | ||
98 | ||
99 | # Test nested anonymous lists. | |
100 | ||
101 | $ref = [[],2,[3,4,5,]]; | |
102 | is (scalar $ref->@*, 3); # is (scalar @$ref, 3); | |
103 | is ($ref->[1], 2); # is ($$ref[1], 2); | |
104 | # is (${$$ref[2]}[2], 5); | |
105 | is (${$ref->[2]}[2], 5); | |
106 | is ($ref->[2]->[2], 5); | |
107 | is ($ref->[2][2], 5); | |
108 | is (scalar $ref->[0]->@*, 0); # is (scalar @{$$ref[0]}, 0); | |
109 | ||
110 | is ($ref->[1], 2); | |
111 | is ($ref->[2]->[0], 3); | |
112 | ||
113 | # Test references to hashes of references. | |
114 | ||
115 | $refref = \%whatever; | |
116 | $refref->{"key"} = $ref; | |
117 | is ($refref->{"key"}->[2]->[0], 3); | |
118 | is ($refref->{"key"}->[2][0], 3); | |
119 | is ($refref->{"key"}[2]->[0], 3); | |
120 | is ($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; | |
126 | push($spring[5]->@*, 789); # push(@{$spring[5]}, 789); | |
127 | is (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; | |
133 | is (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 | } | |
151 | is 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; | |
164 | is ($subrefref->$*->("GOOD"), "good"); # is ($$subrefref->("GOOD"), "good"); | |
165 | sub mysub2 { lc shift } | |
166 | ||
167 | ||
168 | # Test anonymous hash syntax. | |
169 | ||
170 | $anonhash = {}; | |
171 | is (ref $anonhash, 'HASH'); | |
172 | $anonhash2 = {FOO => 'BAR', ABC => 'XYZ',}; | |
173 | is (join('', sort values $anonhash2->%*), 'BARXYZ'); # is (join('', sort values %$anonhash2), 'BARXYZ'); | |
ed3f8f87 | 174 | $anonhash2->{23} = 'tt';@$anonhash2{skiddoo=> 99} = qw/rr nn/; |
2f6fc86f DN |
175 | is(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(); | |
179 | my ($ScopeMark, $Stoogetime) = (1,$test); | |
180 | sub InScope() { $ScopeMark ? "ok " : "not ok " } | |
181 | sub shoulda::DESTROY { print InScope,$test++," - Larry\n"; } | |
182 | sub coulda::DESTROY { print InScope,$test++," - Curly\n"; } | |
183 | sub woulda::DESTROY { print InScope,$test++," - Moe\n"; } | |
184 | sub frieda::DESTROY { print InScope,$test++," - Shemp\n"; } | |
185 | sub spr::DESTROY { print InScope,$test++," - postfix scalar reference\n"; } | |
186 | sub apr::DESTROY { print InScope,$test++," - postfix array reference\n"; } | |
187 | sub 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 | ||
205 | print "# left block\n"; | |
206 | $ScopeMark = 0; | |
207 | curr_test($test); | |
208 | is ($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 | ||
ed3f8f87 FC |
238 | is ($name->$*, undef, 'Nothing before we start'); |
239 | is ($name_utf8->$*, undef, 'Nothing before we start'); | |
2f6fc86f DN |
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 | ||
ed3f8f87 | 303 | is($ref, (eval '$ref->*{IO}'), "IO slot of the temporary glob is set correctly"); |
2f6fc86f DN |
304 | } |
305 | ||
306 | # these will segfault if they fail | |
307 | sub PVBM () { 'foo' } | |
308 | my $pvbm_r; | |
309 | ok(eval q/ $pvbm_r = \'PVBM'->&* /, "postfix symref to sub name"); | |
310 | is("$pvbm_r", "".\&PVBM, "postfix and prefix mechanisms provide same result"); | |
311 | my $pvbm = PVBM; | |
312 | my $rpvbm = \$pvbm; | |
313 | { | |
314 | my $SynCtr; | |
315 | ok (!eval q{ $SynCtr++; $rpvbm->** }, 'PVBM ref is not a GLOB ref'); | |
316 | ok (!eval q{ $SynCtr++; $pvbm->** }, 'PVBM is not a GLOB ref'); | |
317 | is ($SynCtr, 2, "starstar GLOB postderef parses"); | |
318 | } | |
319 | ok (!eval { $pvbm->$* }, 'PVBM is not a SCALAR ref'); | |
320 | ok (!eval { $pvbm->@* }, 'PVBM is not an ARRAY ref'); | |
321 | ok (!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 | ||
76eba8ab FC |
342 | # Postfix key/value slices |
343 | is join(" ", {1..10}->%{1, 7, 3}), "1 2 7 8 3 4", '->%{'; | |
344 | is join(" ", ['a'..'z']->%[1, 7, 3]), "1 b 7 h 3 d", '->%['; | |
2f6fc86f | 345 | |
ff25e5db FC |
346 | # Array length |
347 | is [1..10]->$#*, 9, 'rvalue ->$#*'; | |
348 | @foo = 1..10; | |
349 | (\@foo)->$#*--; | |
350 | is "@foo", "1 2 3 4 5 6 7 8 9", 'lvalue ->$#*'; | |
351 | ||
cc624add FC |
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'; | |
ff25e5db FC |
360 | $# = 43; |
361 | is "$_->$#*", 'foo->43*', '->$#* interpolation without feature'; | |
cc624add FC |
362 | } |
363 | is "$_->@*", 'foo->@*', '->@* does not interpolate without feature'; | |
364 | is "$_->@[0]", 'foo->@[0]', '->@[ does not interpolate without feature'; | |
365 | is "$_->@{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'; | |
ff25e5db | 371 | is "$_->$#*", "2", '->$#* interpolated'; |
cc624add FC |
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'; | |
760ca746 FC |
379 | is "@{[foo->@*]}", "7 8 9", '->@* inside "@{...}"'; |
380 | is "@{[foo->@[0,1]]}", "7 8", '->@[ inside "@{...}"'; | |
381 | is "@{[foo->@{foo}]}", "oof", '->@{ inside "@{...}"'; | |
cc624add | 382 | } |