This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
shrink pp_hot fractionally
[perl5.git] / t / op / ref.t
CommitLineData
79072805
LW
1#!./perl
2
0dd88869 3print "1..56\n";
79072805
LW
4
5# Test glob operations.
6
7$bar = "ok 1\n";
8$foo = "ok 2\n";
9{
10 local(*foo) = *bar;
11 print $foo;
12}
13print $foo;
14
15$baz = "ok 3\n";
16$foo = "ok 4\n";
17{
18 local(*foo) = 'baz';
19 print $foo;
20}
21print $foo;
22
23$foo = "ok 6\n";
24{
25 local(*foo);
26 print $foo;
27 $foo = "ok 5\n";
28 print $foo;
29}
30print $foo;
31
32# Test fake references.
33
34$baz = "ok 7\n";
35$bar = 'baz';
36$foo = 'bar';
37print $$$foo;
38
39# Test real references.
40
41$FOO = \$BAR;
42$BAR = \$BAZ;
43$BAZ = "ok 8\n";
44print $$$FOO;
45
46# Test references to real arrays.
47
48@ary = (9,10,11,12);
49$ref[0] = \@a;
50$ref[1] = \@b;
51$ref[2] = \@c;
52$ref[3] = \@d;
53for $i (3,1,2,0) {
54 push(@{$ref[$i]}, "ok $ary[$i]\n");
55}
56print @a;
57print ${$ref[1]}[0];
58print @{$ref[2]}[0];
59print @{'d'};
60
61# Test references to references.
62
63$refref = \\$x;
64$x = "ok 13\n";
65print $$$refref;
66
67# Test nested anonymous lists.
68
69$ref = [[],2,[3,4,5,]];
70print scalar @$ref == 3 ? "ok 14\n" : "not ok 14\n";
71print $$ref[1] == 2 ? "ok 15\n" : "not ok 15\n";
72print ${$$ref[2]}[2] == 5 ? "ok 16\n" : "not ok 16\n";
73print scalar @{$$ref[0]} == 0 ? "ok 17\n" : "not ok 17\n";
74
75print $ref->[1] == 2 ? "ok 18\n" : "not ok 18\n";
a0d0e21e 76print $ref->[2]->[0] == 3 ? "ok 19\n" : "not ok 19\n";
79072805
LW
77
78# Test references to hashes of references.
79
80$refref = \%whatever;
81$refref->{"key"} = $ref;
82print $refref->{"key"}->[2]->[0] == 3 ? "ok 20\n" : "not ok 20\n";
83
93a17b20 84# Test to see if anonymous subarrays spring into existence.
79072805
LW
85
86$spring[5]->[0] = 123;
87$spring[5]->[1] = 456;
88push(@{$spring[5]}, 789);
89print join(':',@{$spring[5]}) eq "123:456:789" ? "ok 21\n" : "not ok 21\n";
90
93a17b20 91# Test to see if anonymous subhashes spring into existence.
79072805
LW
92
93@{$spring2{"foo"}} = (1,2,3);
94$spring2{"foo"}->[3] = 4;
95print join(':',@{$spring2{"foo"}}) eq "1:2:3:4" ? "ok 22\n" : "not ok 22\n";
96
97# Test references to subroutines.
98
99sub mysub { print "ok 23\n" }
100$subref = \&mysub;
101&$subref;
102
103$subrefref = \\&mysub2;
6da72b64 104$$subrefref->("ok 24\n");
79072805
LW
105sub mysub2 { print shift }
106
107# Test the ref operator.
108
109print ref $subref eq CODE ? "ok 25\n" : "not ok 25\n";
110print ref $ref eq ARRAY ? "ok 26\n" : "not ok 26\n";
111print ref $refref eq HASH ? "ok 27\n" : "not ok 27\n";
112
113# Test anonymous hash syntax.
114
115$anonhash = {};
116print ref $anonhash eq HASH ? "ok 28\n" : "not ok 28\n";
117$anonhash2 = {FOO => BAR, ABC => XYZ,};
118print join('', sort values %$anonhash2) eq BARXYZ ? "ok 29\n" : "not ok 29\n";
119
120# Test bless operator.
121
122package MYHASH;
123
124$object = bless $main'anonhash2;
125print ref $object eq MYHASH ? "ok 30\n" : "not ok 30\n";
126print $object->{ABC} eq XYZ ? "ok 31\n" : "not ok 31\n";
127
128$object2 = bless {};
129print ref $object2 eq MYHASH ? "ok 32\n" : "not ok 32\n";
130
131# Test ordinary call on object method.
132
133&mymethod($object,33);
134
135sub mymethod {
136 local($THIS, @ARGS) = @_;
ed6116ce
LW
137 die 'Got a "' . ref($THIS). '" instead of a MYHASH'
138 unless ref $THIS eq MYHASH;
79072805
LW
139 print $THIS->{FOO} eq BAR ? "ok $ARGS[0]\n" : "not ok $ARGS[0]\n";
140}
141
142# Test automatic destructor call.
143
144$string = "not ok 34\n";
145$object = "foo";
146$string = "ok 34\n";
147$main'anonhash2 = "foo";
8990e307 148$string = "";
79072805 149
ed6116ce 150DESTROY {
8990e307 151 return unless $string;
79072805
LW
152 print $string;
153
a0d0e21e
LW
154 # Test that the object has not already been "cursed".
155 print ref shift ne HASH ? "ok 35\n" : "not ok 35\n";
79072805
LW
156}
157
158# Now test inheritance of methods.
159
160package OBJ;
161
162@ISA = (BASEOBJ);
163
164$main'object = bless {FOO => foo, BAR => bar};
165
166package main;
167
168# Test arrow-style method invocation.
169
170print $object->doit("BAR") eq bar ? "ok 36\n" : "not ok 36\n";
171
172# Test indirect-object-style method invocation.
173
174$foo = doit $object "FOO";
175print $foo eq foo ? "ok 37\n" : "not ok 37\n";
176
177sub BASEOBJ'doit {
178 local $ref = shift;
179 die "Not an OBJ" unless ref $ref eq OBJ;
748a9306 180 $ref->{shift()};
79072805 181}
8990e307 182
a0d0e21e
LW
183package UNIVERSAL;
184@ISA = 'LASTCHANCE';
185
186package LASTCHANCE;
187sub foo { print $_[1] }
188
189package WHATEVER;
190foo WHATEVER "ok 38\n";
191
58e0a6ae
GS
192#
193# test the \(@foo) construct
194#
195package main;
196@foo = (1,2,3);
197@bar = \(@foo);
198@baz = \(1,@foo,@bar);
199print @bar == 3 ? "ok 39\n" : "not ok 39\n";
200print grep(ref($_), @bar) == 3 ? "ok 40\n" : "not ok 40\n";
201print @baz == 3 ? "ok 41\n" : "not ok 41\n";
202
203my(@fuu) = (1,2,3);
204my(@baa) = \(@fuu);
205my(@bzz) = \(1,@fuu,@baa);
206print @baa == 3 ? "ok 42\n" : "not ok 42\n";
207print grep(ref($_), @baa) == 3 ? "ok 43\n" : "not ok 43\n";
208print @bzz == 3 ? "ok 44\n" : "not ok 44\n";
209
bc44cdaf
GS
210# test for proper destruction of lexical objects
211
212sub larry::DESTROY { print "# larry\nok 45\n"; }
213sub curly::DESTROY { print "# curly\nok 46\n"; }
214sub moe::DESTROY { print "# moe\nok 47\n"; }
215
216{
217 my ($joe, @curly, %larry);
218 my $moe = bless \$joe, 'moe';
219 my $curly = bless \@curly, 'curly';
220 my $larry = bless \%larry, 'larry';
221 print "# leaving block\n";
222}
223
224print "# left block\n";
225
fb73857a
PP
226# another glob test
227
228$foo = "not ok 48";
229{ local(*bar) = "foo" }
230$bar = "ok 48";
231local(*bar) = *bar;
232print "$bar\n";
233
d4010388
NIS
234$var = "ok 49";
235$_ = \$var;
236print $$_,"\n";
237
4e8e7886
GS
238# test if reblessing during destruction results in more destruction
239
240{
241 package A;
242 sub new { bless {}, shift }
243 DESTROY { print "# destroying 'A'\nok 51\n" }
8bac7e00 244 package _B;
4e8e7886 245 sub new { bless {}, shift }
8bac7e00 246 DESTROY { print "# destroying '_B'\nok 50\n"; bless shift, 'A' }
4e8e7886 247 package main;
8bac7e00 248 my $b = _B->new;
4e8e7886
GS
249}
250
251# test if $_[0] is properly protected in DESTROY()
252
253{
254 my $i = 0;
255 local $SIG{'__DIE__'} = sub {
256 my $m = shift;
257 if ($i++ > 4) {
258 print "# infinite recursion, bailing\nnot ok 52\n";
259 exit 1;
260 }
261 print "# $m";
262 if ($m =~ /^Modification of a read-only/) { print "ok 52\n" }
263 };
264 package C;
265 sub new { bless {}, shift }
266 DESTROY { $_[0] = 'foo' }
267 {
268 print "# should generate an error...\n";
269 my $c = C->new;
270 }
271 print "# good, didn't recurse\n";
272}
273
0dd88869
GS
274# test if refgen behaves with autoviv magic
275
276{
277 my @a;
278 $a[1] = "ok 53\n";
279 print ${\$_} for @a;
280}
281
4e8e7886
GS
282# test global destruction
283
8990e307
LW
284package FINALE;
285
286{
0dd88869
GS
287 $ref3 = bless ["ok 56\n"]; # package destruction
288 my $ref2 = bless ["ok 55\n"]; # lexical destruction
289 local $ref1 = bless ["ok 54\n"]; # dynamic destruction
8990e307
LW
290 1; # flush any temp values on stack
291}
292
293DESTROY {
294 print $_[0][0];
295}