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