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