This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Start converting t/op/ref.t to use test.pl
[perl5.git] / t / op / ref.t
CommitLineData
79072805
LW
1#!./perl
2
20274adc
JH
3BEGIN {
4 chdir 't' if -d 't';
b5fe401b 5 @INC = qw(. ../lib);
20274adc
JH
6}
7
b2ce0fda 8require 'test.pl';
79072805 9
805232b4
NC
10plan (72);
11
79072805
LW
12# Test glob operations.
13
14$bar = "ok 1\n";
15$foo = "ok 2\n";
16{
17 local(*foo) = *bar;
18 print $foo;
19}
20print $foo;
21
22$baz = "ok 3\n";
23$foo = "ok 4\n";
24{
25 local(*foo) = 'baz';
26 print $foo;
27}
28print $foo;
29
30$foo = "ok 6\n";
31{
32 local(*foo);
33 print $foo;
34 $foo = "ok 5\n";
35 print $foo;
36}
37print $foo;
38
39# Test fake references.
40
41$baz = "ok 7\n";
42$bar = 'baz';
43$foo = 'bar';
44print $$$foo;
45
46# Test real references.
47
48$FOO = \$BAR;
49$BAR = \$BAZ;
50$BAZ = "ok 8\n";
51print $$$FOO;
52
53# Test references to real arrays.
54
55@ary = (9,10,11,12);
56$ref[0] = \@a;
57$ref[1] = \@b;
58$ref[2] = \@c;
59$ref[3] = \@d;
60for $i (3,1,2,0) {
61 push(@{$ref[$i]}, "ok $ary[$i]\n");
62}
63print @a;
64print ${$ref[1]}[0];
65print @{$ref[2]}[0];
66print @{'d'};
67
68# Test references to references.
69
70$refref = \\$x;
71$x = "ok 13\n";
72print $$$refref;
73
74# Test nested anonymous lists.
75
76$ref = [[],2,[3,4,5,]];
77print scalar @$ref == 3 ? "ok 14\n" : "not ok 14\n";
78print $$ref[1] == 2 ? "ok 15\n" : "not ok 15\n";
79print ${$$ref[2]}[2] == 5 ? "ok 16\n" : "not ok 16\n";
80print scalar @{$$ref[0]} == 0 ? "ok 17\n" : "not ok 17\n";
81
82print $ref->[1] == 2 ? "ok 18\n" : "not ok 18\n";
a0d0e21e 83print $ref->[2]->[0] == 3 ? "ok 19\n" : "not ok 19\n";
79072805
LW
84
85# Test references to hashes of references.
86
87$refref = \%whatever;
88$refref->{"key"} = $ref;
89print $refref->{"key"}->[2]->[0] == 3 ? "ok 20\n" : "not ok 20\n";
90
93a17b20 91# Test to see if anonymous subarrays spring into existence.
79072805
LW
92
93$spring[5]->[0] = 123;
94$spring[5]->[1] = 456;
95push(@{$spring[5]}, 789);
96print join(':',@{$spring[5]}) eq "123:456:789" ? "ok 21\n" : "not ok 21\n";
97
93a17b20 98# Test to see if anonymous subhashes spring into existence.
79072805
LW
99
100@{$spring2{"foo"}} = (1,2,3);
101$spring2{"foo"}->[3] = 4;
102print join(':',@{$spring2{"foo"}}) eq "1:2:3:4" ? "ok 22\n" : "not ok 22\n";
103
104# Test references to subroutines.
105
106sub mysub { print "ok 23\n" }
107$subref = \&mysub;
108&$subref;
109
110$subrefref = \\&mysub2;
6da72b64 111$$subrefref->("ok 24\n");
79072805
LW
112sub mysub2 { print shift }
113
114# Test the ref operator.
115
116print ref $subref eq CODE ? "ok 25\n" : "not ok 25\n";
117print ref $ref eq ARRAY ? "ok 26\n" : "not ok 26\n";
118print ref $refref eq HASH ? "ok 27\n" : "not ok 27\n";
119
120# Test anonymous hash syntax.
121
122$anonhash = {};
123print ref $anonhash eq HASH ? "ok 28\n" : "not ok 28\n";
124$anonhash2 = {FOO => BAR, ABC => XYZ,};
125print join('', sort values %$anonhash2) eq BARXYZ ? "ok 29\n" : "not ok 29\n";
126
127# Test bless operator.
128
129package MYHASH;
130
131$object = bless $main'anonhash2;
132print ref $object eq MYHASH ? "ok 30\n" : "not ok 30\n";
133print $object->{ABC} eq XYZ ? "ok 31\n" : "not ok 31\n";
134
135$object2 = bless {};
136print ref $object2 eq MYHASH ? "ok 32\n" : "not ok 32\n";
137
138# Test ordinary call on object method.
139
140&mymethod($object,33);
141
142sub mymethod {
143 local($THIS, @ARGS) = @_;
ed6116ce
LW
144 die 'Got a "' . ref($THIS). '" instead of a MYHASH'
145 unless ref $THIS eq MYHASH;
79072805
LW
146 print $THIS->{FOO} eq BAR ? "ok $ARGS[0]\n" : "not ok $ARGS[0]\n";
147}
148
149# Test automatic destructor call.
150
151$string = "not ok 34\n";
152$object = "foo";
153$string = "ok 34\n";
154$main'anonhash2 = "foo";
8990e307 155$string = "";
79072805 156
ed6116ce 157DESTROY {
8990e307 158 return unless $string;
79072805
LW
159 print $string;
160
a0d0e21e
LW
161 # Test that the object has not already been "cursed".
162 print ref shift ne HASH ? "ok 35\n" : "not ok 35\n";
79072805
LW
163}
164
165# Now test inheritance of methods.
166
167package OBJ;
168
169@ISA = (BASEOBJ);
170
171$main'object = bless {FOO => foo, BAR => bar};
172
173package main;
805232b4 174curr_test(36);
79072805
LW
175
176# Test arrow-style method invocation.
177
805232b4 178is ($object->doit("BAR"), bar);
79072805
LW
179
180# Test indirect-object-style method invocation.
181
182$foo = doit $object "FOO";
805232b4 183main::is ($foo, foo);
79072805
LW
184
185sub BASEOBJ'doit {
186 local $ref = shift;
187 die "Not an OBJ" unless ref $ref eq OBJ;
748a9306 188 $ref->{shift()};
79072805 189}
8990e307 190
a0d0e21e
LW
191package UNIVERSAL;
192@ISA = 'LASTCHANCE';
193
194package LASTCHANCE;
805232b4 195sub foo { main::is ($_[1], 'works') }
a0d0e21e
LW
196
197package WHATEVER;
805232b4 198foo WHATEVER "works";
a0d0e21e 199
58e0a6ae
GS
200#
201# test the \(@foo) construct
202#
203package main;
fb53bbb2 204@foo = \(1..3);
58e0a6ae
GS
205@bar = \(@foo);
206@baz = \(1,@foo,@bar);
805232b4
NC
207is (scalar (@bar), 3);
208is (scalar grep(ref($_), @bar), 3);
209is (scalar (@baz), 3);
58e0a6ae 210
fb53bbb2 211my(@fuu) = \(1..2,3);
58e0a6ae
GS
212my(@baa) = \(@fuu);
213my(@bzz) = \(1,@fuu,@baa);
805232b4
NC
214is (scalar (@baa), 3);
215is (scalar grep(ref($_), @baa), 3);
216is (scalar (@bzz), 3);
58e0a6ae 217
75ea820e
SM
218# also, it can't be an lvalue
219eval '\\($x, $y) = (1, 2);';
805232b4 220like ($@, qr/Can\'t modify.*ref.*in.*assignment/);
75ea820e 221
bc44cdaf 222# test for proper destruction of lexical objects
805232b4
NC
223my $test = curr_test();
224sub larry::DESTROY { print "# larry\nok $test\n"; }
225sub curly::DESTROY { print "# curly\nok ", $test + 1, "\n"; }
226sub moe::DESTROY { print "# moe\nok ", $test + 2, "\n"; }
bc44cdaf
GS
227
228{
229 my ($joe, @curly, %larry);
230 my $moe = bless \$joe, 'moe';
231 my $curly = bless \@curly, 'curly';
232 my $larry = bless \%larry, 'larry';
233 print "# leaving block\n";
234}
235
236print "# left block\n";
805232b4 237curr_test($test + 3);
bc44cdaf 238
fb73857a
PP
239# another glob test
240
805232b4
NC
241
242$foo = "garbage";
fb73857a 243{ local(*bar) = "foo" }
805232b4 244$bar = "glob 3";
fb73857a 245local(*bar) = *bar;
805232b4 246is ($bar, "glob 3");
fb73857a 247
805232b4 248$var = "glob 4";
d4010388 249$_ = \$var;
805232b4 250is ($$_, 'glob 4');
d4010388 251
4e8e7886 252
805232b4
NC
253# test if reblessing during destruction results in more destruction
254$test = curr_test();
4e8e7886
GS
255{
256 package A;
257 sub new { bless {}, shift }
805232b4 258 DESTROY { print "# destroying 'A'\nok ", $test + 1, "\n" }
8bac7e00 259 package _B;
4e8e7886 260 sub new { bless {}, shift }
805232b4 261 DESTROY { print "# destroying '_B'\nok $test\n"; bless shift, 'A' }
4e8e7886 262 package main;
8bac7e00 263 my $b = _B->new;
4e8e7886 264}
805232b4 265curr_test($test + 2);
4e8e7886
GS
266
267# test if $_[0] is properly protected in DESTROY()
268
269{
805232b4 270 my $test = curr_test();
4e8e7886
GS
271 my $i = 0;
272 local $SIG{'__DIE__'} = sub {
273 my $m = shift;
274 if ($i++ > 4) {
805232b4 275 print "# infinite recursion, bailing\nnot ok $test\n";
4e8e7886
GS
276 exit 1;
277 }
805232b4 278 like ($m, qr/^Modification of a read-only/);
4e8e7886
GS
279 };
280 package C;
281 sub new { bless {}, shift }
282 DESTROY { $_[0] = 'foo' }
283 {
284 print "# should generate an error...\n";
285 my $c = C->new;
286 }
287 print "# good, didn't recurse\n";
288}
289
0dd88869 290# test if refgen behaves with autoviv magic
0dd88869
GS
291{
292 my @a;
805232b4
NC
293 $a[1] = "good";
294 my $got;
295 for (@a) {
296 $got .= ${\$_};
297 $got .= ';';
298 }
299 is ($got, ";good;");
0dd88869
GS
300}
301
840a7b70
IZ
302# This test is the reason for postponed destruction in sv_unref
303$a = [1,2,3];
304$a = $a->[1];
805232b4 305is ($a, 2);
840a7b70 306
04ca4930
NC
307# This test used to coredump. The BEGIN block is important as it causes the
308# op that created the constant reference to be freed. Hence the only
309# reference to the constant string "pass" is in $a. The hack that made
310# sure $a = $a->[1] would work didn't work with references to constants.
311
04ca4930
NC
312
313foreach my $lexical ('', 'my $a; ') {
314 my $expect = "pass\n";
315 my $result = runperl (switches => ['-wl'], stderr => 1,
316 prog => $lexical . 'BEGIN {$a = \q{pass}}; $a = $$a; print $a');
317
805232b4
NC
318 is ($?, 0);
319 is ($result, $expect);
840a7b70
IZ
320}
321
805232b4 322my $test = curr_test();
04ca4930
NC
323sub x::DESTROY {print "ok ", $test + shift->[0], "\n"}
324{ my $a1 = bless [3],"x";
325 my $a2 = bless [2],"x";
326 { my $a3 = bless [1],"x";
327 my $a4 = bless [0],"x";
328 567;
329 }
330}
805232b4
NC
331curr_test($test+4);
332
333is (runperl (switches=>['-l'],
334 prog=> 'print 1; print qq-*$\*-;print 1;'),
335 "1\n*\n*\n1\n");
b2ce0fda 336
39cff0d9
AE
337# bug #21347
338
339runperl(prog => 'sub UNIVERSAL::AUTOLOAD { qr// } a->p' );
805232b4 340is ($?, 0, 'UNIVERSAL::AUTOLOAD called when freeing qr//');
39cff0d9 341
7b102d90 342runperl(prog => 'sub UNIVERSAL::DESTROY { warn } bless \$a, A', stderr => 1);
805232b4 343is ($?, 0, 'warn called inside UNIVERSAL::DESTROY');
7b102d90 344
23bb1b96
DM
345
346# bug #22719
347
348runperl(prog => 'sub f { my $x = shift; *z = $x; } f({}); f();');
805232b4 349is ($?, 0, 'coredump on typeglob = (SvRV && !SvROK)');
23bb1b96 350
ec5f3c78
DM
351# bug #27268: freeing self-referential typeglobs could trigger
352# "Attempt to free unreferenced scalar" warnings
353
805232b4 354is (runperl(
ec5f3c78
DM
355 prog => 'use Symbol;my $x=bless \gensym,"t"; print;*$$x=$x',
356 stderr => 1
805232b4 357), '', 'freeing self-referential typeglob');
23bb1b96 358
804ffa60
DM
359# using a regex in the destructor for STDOUT segfaulted because the
360# REGEX pad had already been freed (ithreads build only). The
361# object is required to trigger the early freeing of GV refs to to STDOUT
362
805232b4 363like (runperl(
804ffa60
DM
364 prog => '$x=bless[]; sub IO::Handle::DESTROY{$_="bad";s/bad/ok/;print}',
365 stderr => 1
805232b4 366 ), qr/^(ok)+$/, 'STDOUT destructor');
804ffa60 367
805232b4
NC
368# Bit of a hack to make test.pl happy. There are 3 more tests after it leaves.
369$test = curr_test();
370curr_test($test + 3);
4e8e7886
GS
371# test global destruction
372
840a7b70
IZ
373my $test1 = $test + 1;
374my $test2 = $test + 2;
375
8990e307
LW
376package FINALE;
377
378{
840a7b70
IZ
379 $ref3 = bless ["ok $test2\n"]; # package destruction
380 my $ref2 = bless ["ok $test1\n"]; # lexical destruction
381 local $ref1 = bless ["ok $test\n"]; # dynamic destruction
8990e307
LW
382 1; # flush any temp values on stack
383}
384
385DESTROY {
386 print $_[0][0];
387}
804ffa60 388