xref: /openbsd-src/gnu/usr.bin/perl/t/op/ref.t (revision e2e5c5d36e4398ba94879f0a31b0307421edcfdb)
1#!./perl
2
3print "1..56\n";
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";
76print $ref->[2]->[0] == 3 ? "ok 19\n" : "not ok 19\n";
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
84# Test to see if anonymous subarrays spring into existence.
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
91# Test to see if anonymous subhashes spring into existence.
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;
104$$subrefref->("ok 24\n");
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) = @_;
137    die 'Got a "' . ref($THIS). '" instead of a MYHASH'
138	unless ref $THIS eq MYHASH;
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";
148$string = "";
149
150DESTROY {
151    return unless $string;
152    print $string;
153
154    # Test that the object has not already been "cursed".
155    print ref shift ne HASH ? "ok 35\n" : "not ok 35\n";
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;
180    $ref->{shift()};
181}
182
183package UNIVERSAL;
184@ISA = 'LASTCHANCE';
185
186package LASTCHANCE;
187sub foo { print $_[1] }
188
189package WHATEVER;
190foo WHATEVER "ok 38\n";
191
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
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
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
234$var = "ok 49";
235$_   = \$var;
236print $$_,"\n";
237
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" }
244    package _B;
245    sub new { bless {}, shift }
246    DESTROY { print "# destroying '_B'\nok 50\n"; bless shift, 'A' }
247    package main;
248    my $b = _B->new;
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
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
282# test global destruction
283
284package FINALE;
285
286{
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
290    1;					# flush any temp values on stack
291}
292
293DESTROY {
294    print $_[0][0];
295}
296