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