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