Commit | Line | Data |
79072805 |
1 | #!./perl |
2 | |
20274adc |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
b5fe401b |
5 | @INC = qw(. ../lib); |
20274adc |
6 | } |
7 | |
b2ce0fda |
8 | require 'test.pl'; |
79072805 |
9 | |
805232b4 |
10 | plan (72); |
11 | |
79072805 |
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 |
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 |
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 |
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 |
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 |
144 | die 'Got a "' . ref($THIS). '" instead of a MYHASH' |
145 | unless ref $THIS eq MYHASH; |
79072805 |
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 |
159 | print $string; |
160 | |
a0d0e21e |
161 | # Test that the object has not already been "cursed". |
162 | print ref shift ne HASH ? "ok 35\n" : "not ok 35\n"; |
79072805 |
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; |
805232b4 |
174 | curr_test(36); |
79072805 |
175 | |
176 | # Test arrow-style method invocation. |
177 | |
805232b4 |
178 | is ($object->doit("BAR"), bar); |
79072805 |
179 | |
180 | # Test indirect-object-style method invocation. |
181 | |
182 | $foo = doit $object "FOO"; |
805232b4 |
183 | main::is ($foo, foo); |
79072805 |
184 | |
185 | sub BASEOBJ'doit { |
186 | local $ref = shift; |
187 | die "Not an OBJ" unless ref $ref eq OBJ; |
748a9306 |
188 | $ref->{shift()}; |
79072805 |
189 | } |
8990e307 |
190 | |
a0d0e21e |
191 | package UNIVERSAL; |
192 | @ISA = 'LASTCHANCE'; |
193 | |
194 | package LASTCHANCE; |
805232b4 |
195 | sub foo { main::is ($_[1], 'works') } |
a0d0e21e |
196 | |
197 | package WHATEVER; |
805232b4 |
198 | foo WHATEVER "works"; |
a0d0e21e |
199 | |
58e0a6ae |
200 | # |
201 | # test the \(@foo) construct |
202 | # |
203 | package main; |
fb53bbb2 |
204 | @foo = \(1..3); |
58e0a6ae |
205 | @bar = \(@foo); |
206 | @baz = \(1,@foo,@bar); |
805232b4 |
207 | is (scalar (@bar), 3); |
208 | is (scalar grep(ref($_), @bar), 3); |
209 | is (scalar (@baz), 3); |
58e0a6ae |
210 | |
fb53bbb2 |
211 | my(@fuu) = \(1..2,3); |
58e0a6ae |
212 | my(@baa) = \(@fuu); |
213 | my(@bzz) = \(1,@fuu,@baa); |
805232b4 |
214 | is (scalar (@baa), 3); |
215 | is (scalar grep(ref($_), @baa), 3); |
216 | is (scalar (@bzz), 3); |
58e0a6ae |
217 | |
75ea820e |
218 | # also, it can't be an lvalue |
219 | eval '\\($x, $y) = (1, 2);'; |
805232b4 |
220 | like ($@, qr/Can\'t modify.*ref.*in.*assignment/); |
75ea820e |
221 | |
bc44cdaf |
222 | # test for proper destruction of lexical objects |
805232b4 |
223 | my $test = curr_test(); |
224 | sub larry::DESTROY { print "# larry\nok $test\n"; } |
225 | sub curly::DESTROY { print "# curly\nok ", $test + 1, "\n"; } |
226 | sub moe::DESTROY { print "# moe\nok ", $test + 2, "\n"; } |
bc44cdaf |
227 | |
228 | { |
229 | my ($joe, @curly, %larry); |
230 | my $moe = bless \$joe, 'moe'; |
231 | my $curly = bless \@curly, 'curly'; |
232 | my $larry = bless \%larry, 'larry'; |
233 | print "# leaving block\n"; |
234 | } |
235 | |
236 | print "# left block\n"; |
805232b4 |
237 | curr_test($test + 3); |
bc44cdaf |
238 | |
fb73857a |
239 | # another glob test |
240 | |
805232b4 |
241 | |
242 | $foo = "garbage"; |
fb73857a |
243 | { local(*bar) = "foo" } |
805232b4 |
244 | $bar = "glob 3"; |
fb73857a |
245 | local(*bar) = *bar; |
805232b4 |
246 | is ($bar, "glob 3"); |
fb73857a |
247 | |
805232b4 |
248 | $var = "glob 4"; |
d4010388 |
249 | $_ = \$var; |
805232b4 |
250 | is ($$_, 'glob 4'); |
d4010388 |
251 | |
4e8e7886 |
252 | |
805232b4 |
253 | # test if reblessing during destruction results in more destruction |
254 | $test = curr_test(); |
4e8e7886 |
255 | { |
256 | package A; |
257 | sub new { bless {}, shift } |
805232b4 |
258 | DESTROY { print "# destroying 'A'\nok ", $test + 1, "\n" } |
8bac7e00 |
259 | package _B; |
4e8e7886 |
260 | sub new { bless {}, shift } |
805232b4 |
261 | DESTROY { print "# destroying '_B'\nok $test\n"; bless shift, 'A' } |
4e8e7886 |
262 | package main; |
8bac7e00 |
263 | my $b = _B->new; |
4e8e7886 |
264 | } |
805232b4 |
265 | curr_test($test + 2); |
4e8e7886 |
266 | |
267 | # test if $_[0] is properly protected in DESTROY() |
268 | |
269 | { |
805232b4 |
270 | my $test = curr_test(); |
4e8e7886 |
271 | my $i = 0; |
272 | local $SIG{'__DIE__'} = sub { |
273 | my $m = shift; |
274 | if ($i++ > 4) { |
805232b4 |
275 | print "# infinite recursion, bailing\nnot ok $test\n"; |
4e8e7886 |
276 | exit 1; |
277 | } |
805232b4 |
278 | like ($m, qr/^Modification of a read-only/); |
4e8e7886 |
279 | }; |
280 | package C; |
281 | sub new { bless {}, shift } |
282 | DESTROY { $_[0] = 'foo' } |
283 | { |
284 | print "# should generate an error...\n"; |
285 | my $c = C->new; |
286 | } |
287 | print "# good, didn't recurse\n"; |
288 | } |
289 | |
0dd88869 |
290 | # test if refgen behaves with autoviv magic |
0dd88869 |
291 | { |
292 | my @a; |
805232b4 |
293 | $a[1] = "good"; |
294 | my $got; |
295 | for (@a) { |
296 | $got .= ${\$_}; |
297 | $got .= ';'; |
298 | } |
299 | is ($got, ";good;"); |
0dd88869 |
300 | } |
301 | |
840a7b70 |
302 | # This test is the reason for postponed destruction in sv_unref |
303 | $a = [1,2,3]; |
304 | $a = $a->[1]; |
805232b4 |
305 | is ($a, 2); |
840a7b70 |
306 | |
04ca4930 |
307 | # This test used to coredump. The BEGIN block is important as it causes the |
308 | # op that created the constant reference to be freed. Hence the only |
309 | # reference to the constant string "pass" is in $a. The hack that made |
310 | # sure $a = $a->[1] would work didn't work with references to constants. |
311 | |
04ca4930 |
312 | |
313 | foreach my $lexical ('', 'my $a; ') { |
314 | my $expect = "pass\n"; |
315 | my $result = runperl (switches => ['-wl'], stderr => 1, |
316 | prog => $lexical . 'BEGIN {$a = \q{pass}}; $a = $$a; print $a'); |
317 | |
805232b4 |
318 | is ($?, 0); |
319 | is ($result, $expect); |
840a7b70 |
320 | } |
321 | |
805232b4 |
322 | my $test = curr_test(); |
04ca4930 |
323 | sub x::DESTROY {print "ok ", $test + shift->[0], "\n"} |
324 | { my $a1 = bless [3],"x"; |
325 | my $a2 = bless [2],"x"; |
326 | { my $a3 = bless [1],"x"; |
327 | my $a4 = bless [0],"x"; |
328 | 567; |
329 | } |
330 | } |
805232b4 |
331 | curr_test($test+4); |
332 | |
333 | is (runperl (switches=>['-l'], |
334 | prog=> 'print 1; print qq-*$\*-;print 1;'), |
335 | "1\n*\n*\n1\n"); |
b2ce0fda |
336 | |
39cff0d9 |
337 | # bug #21347 |
338 | |
339 | runperl(prog => 'sub UNIVERSAL::AUTOLOAD { qr// } a->p' ); |
805232b4 |
340 | is ($?, 0, 'UNIVERSAL::AUTOLOAD called when freeing qr//'); |
39cff0d9 |
341 | |
7b102d90 |
342 | runperl(prog => 'sub UNIVERSAL::DESTROY { warn } bless \$a, A', stderr => 1); |
805232b4 |
343 | is ($?, 0, 'warn called inside UNIVERSAL::DESTROY'); |
7b102d90 |
344 | |
23bb1b96 |
345 | |
346 | # bug #22719 |
347 | |
348 | runperl(prog => 'sub f { my $x = shift; *z = $x; } f({}); f();'); |
805232b4 |
349 | is ($?, 0, 'coredump on typeglob = (SvRV && !SvROK)'); |
23bb1b96 |
350 | |
ec5f3c78 |
351 | # bug #27268: freeing self-referential typeglobs could trigger |
352 | # "Attempt to free unreferenced scalar" warnings |
353 | |
805232b4 |
354 | is (runperl( |
ec5f3c78 |
355 | prog => 'use Symbol;my $x=bless \gensym,"t"; print;*$$x=$x', |
356 | stderr => 1 |
805232b4 |
357 | ), '', 'freeing self-referential typeglob'); |
23bb1b96 |
358 | |
804ffa60 |
359 | # using a regex in the destructor for STDOUT segfaulted because the |
360 | # REGEX pad had already been freed (ithreads build only). The |
361 | # object is required to trigger the early freeing of GV refs to to STDOUT |
362 | |
805232b4 |
363 | like (runperl( |
804ffa60 |
364 | prog => '$x=bless[]; sub IO::Handle::DESTROY{$_="bad";s/bad/ok/;print}', |
365 | stderr => 1 |
805232b4 |
366 | ), qr/^(ok)+$/, 'STDOUT destructor'); |
804ffa60 |
367 | |
805232b4 |
368 | # Bit of a hack to make test.pl happy. There are 3 more tests after it leaves. |
369 | $test = curr_test(); |
370 | curr_test($test + 3); |
4e8e7886 |
371 | # test global destruction |
372 | |
840a7b70 |
373 | my $test1 = $test + 1; |
374 | my $test2 = $test + 2; |
375 | |
8990e307 |
376 | package FINALE; |
377 | |
378 | { |
840a7b70 |
379 | $ref3 = bless ["ok $test2\n"]; # package destruction |
380 | my $ref2 = bless ["ok $test1\n"]; # lexical destruction |
381 | local $ref1 = bless ["ok $test\n"]; # dynamic destruction |
8990e307 |
382 | 1; # flush any temp values on stack |
383 | } |
384 | |
385 | DESTROY { |
386 | print $_[0][0]; |
387 | } |
804ffa60 |
388 | |