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 | |
1c509eb9 |
10 | plan (74); |
805232b4 |
11 | |
79072805 |
12 | # Test glob operations. |
13 | |
1c509eb9 |
14 | $bar = "one"; |
15 | $foo = "two"; |
79072805 |
16 | { |
17 | local(*foo) = *bar; |
1c509eb9 |
18 | is($foo, 'one'); |
79072805 |
19 | } |
1c509eb9 |
20 | is ($foo, 'two'); |
79072805 |
21 | |
1c509eb9 |
22 | $baz = "three"; |
23 | $foo = "four"; |
79072805 |
24 | { |
25 | local(*foo) = 'baz'; |
1c509eb9 |
26 | is ($foo, 'three'); |
79072805 |
27 | } |
1c509eb9 |
28 | is ($foo, 'four'); |
79072805 |
29 | |
1c509eb9 |
30 | $foo = "global"; |
79072805 |
31 | { |
32 | local(*foo); |
1c509eb9 |
33 | is ($foo, undef); |
34 | $foo = "local"; |
35 | is ($foo, 'local'); |
79072805 |
36 | } |
1c509eb9 |
37 | is ($foo, 'global'); |
79072805 |
38 | |
39 | # Test fake references. |
40 | |
1c509eb9 |
41 | $baz = "valid"; |
79072805 |
42 | $bar = 'baz'; |
43 | $foo = 'bar'; |
1c509eb9 |
44 | is ($$$foo, 'valid'); |
79072805 |
45 | |
46 | # Test real references. |
47 | |
48 | $FOO = \$BAR; |
49 | $BAR = \$BAZ; |
1c509eb9 |
50 | $BAZ = "hit"; |
51 | is ($$$FOO, 'hit'); |
79072805 |
52 | |
53 | # Test references to real arrays. |
54 | |
1c509eb9 |
55 | my $test = curr_test(); |
56 | @ary = ($test,$test+1,$test+2,$test+3); |
79072805 |
57 | $ref[0] = \@a; |
58 | $ref[1] = \@b; |
59 | $ref[2] = \@c; |
60 | $ref[3] = \@d; |
61 | for $i (3,1,2,0) { |
62 | push(@{$ref[$i]}, "ok $ary[$i]\n"); |
63 | } |
64 | print @a; |
65 | print ${$ref[1]}[0]; |
66 | print @{$ref[2]}[0]; |
67 | print @{'d'}; |
1c509eb9 |
68 | curr_test($test+4); |
79072805 |
69 | |
70 | # Test references to references. |
71 | |
72 | $refref = \\$x; |
1c509eb9 |
73 | $x = "Good"; |
74 | is ($$$refref, 'Good'); |
79072805 |
75 | |
76 | # Test nested anonymous lists. |
77 | |
78 | $ref = [[],2,[3,4,5,]]; |
1c509eb9 |
79 | is (scalar @$ref, 3); |
80 | is ($$ref[1], 2); |
81 | is (${$$ref[2]}[2], 5); |
82 | is (scalar @{$$ref[0]}, 0); |
79072805 |
83 | |
1c509eb9 |
84 | is ($ref->[1], 2); |
85 | is ($ref->[2]->[0], 3); |
79072805 |
86 | |
87 | # Test references to hashes of references. |
88 | |
89 | $refref = \%whatever; |
90 | $refref->{"key"} = $ref; |
1c509eb9 |
91 | is ($refref->{"key"}->[2]->[0], 3); |
79072805 |
92 | |
93a17b20 |
93 | # Test to see if anonymous subarrays spring into existence. |
79072805 |
94 | |
95 | $spring[5]->[0] = 123; |
96 | $spring[5]->[1] = 456; |
97 | push(@{$spring[5]}, 789); |
1c509eb9 |
98 | is (join(':',@{$spring[5]}), "123:456:789"); |
79072805 |
99 | |
93a17b20 |
100 | # Test to see if anonymous subhashes spring into existence. |
79072805 |
101 | |
102 | @{$spring2{"foo"}} = (1,2,3); |
103 | $spring2{"foo"}->[3] = 4; |
1c509eb9 |
104 | is (join(':',@{$spring2{"foo"}}), "1:2:3:4"); |
79072805 |
105 | |
106 | # Test references to subroutines. |
107 | |
1c509eb9 |
108 | { |
109 | my $called; |
110 | sub mysub { $called++; } |
111 | $subref = \&mysub; |
112 | &$subref; |
113 | is ($called, 1); |
114 | } |
79072805 |
115 | |
116 | $subrefref = \\&mysub2; |
1c509eb9 |
117 | is ($$subrefref->("GOOD"), "good"); |
118 | sub mysub2 { lc shift } |
79072805 |
119 | |
120 | # Test the ref operator. |
121 | |
1c509eb9 |
122 | is (ref $subref, 'CODE'); |
123 | is (ref $ref, 'ARRAY'); |
124 | is (ref $refref, 'HASH'); |
79072805 |
125 | |
126 | # Test anonymous hash syntax. |
127 | |
128 | $anonhash = {}; |
1c509eb9 |
129 | is (ref $anonhash, 'HASH'); |
79072805 |
130 | $anonhash2 = {FOO => BAR, ABC => XYZ,}; |
1c509eb9 |
131 | is (join('', sort values %$anonhash2), 'BARXYZ'); |
79072805 |
132 | |
133 | # Test bless operator. |
134 | |
135 | package MYHASH; |
136 | |
137 | $object = bless $main'anonhash2; |
1c509eb9 |
138 | main::is (ref $object, 'MYHASH'); |
139 | main::is ($object->{ABC}, 'XYZ'); |
79072805 |
140 | |
141 | $object2 = bless {}; |
1c509eb9 |
142 | main::is (ref $object2, 'MYHASH'); |
79072805 |
143 | |
144 | # Test ordinary call on object method. |
145 | |
1c509eb9 |
146 | &mymethod($object,"argument"); |
79072805 |
147 | |
148 | sub mymethod { |
149 | local($THIS, @ARGS) = @_; |
ed6116ce |
150 | die 'Got a "' . ref($THIS). '" instead of a MYHASH' |
151 | unless ref $THIS eq MYHASH; |
1c509eb9 |
152 | main::is ($ARGS[0], "argument"); |
153 | main::is ($THIS->{FOO}, 'BAR'); |
79072805 |
154 | } |
155 | |
156 | # Test automatic destructor call. |
157 | |
1c509eb9 |
158 | $string = "bad"; |
79072805 |
159 | $object = "foo"; |
1c509eb9 |
160 | $string = "good"; |
79072805 |
161 | $main'anonhash2 = "foo"; |
8990e307 |
162 | $string = ""; |
79072805 |
163 | |
ed6116ce |
164 | DESTROY { |
8990e307 |
165 | return unless $string; |
1c509eb9 |
166 | main::is ($string, 'good'); |
79072805 |
167 | |
a0d0e21e |
168 | # Test that the object has not already been "cursed". |
1c509eb9 |
169 | main::isnt (ref shift, 'HASH'); |
79072805 |
170 | } |
171 | |
172 | # Now test inheritance of methods. |
173 | |
174 | package OBJ; |
175 | |
176 | @ISA = (BASEOBJ); |
177 | |
178 | $main'object = bless {FOO => foo, BAR => bar}; |
179 | |
180 | package main; |
181 | |
182 | # Test arrow-style method invocation. |
183 | |
805232b4 |
184 | is ($object->doit("BAR"), bar); |
79072805 |
185 | |
186 | # Test indirect-object-style method invocation. |
187 | |
188 | $foo = doit $object "FOO"; |
805232b4 |
189 | main::is ($foo, foo); |
79072805 |
190 | |
191 | sub BASEOBJ'doit { |
192 | local $ref = shift; |
193 | die "Not an OBJ" unless ref $ref eq OBJ; |
748a9306 |
194 | $ref->{shift()}; |
79072805 |
195 | } |
8990e307 |
196 | |
a0d0e21e |
197 | package UNIVERSAL; |
198 | @ISA = 'LASTCHANCE'; |
199 | |
200 | package LASTCHANCE; |
805232b4 |
201 | sub foo { main::is ($_[1], 'works') } |
a0d0e21e |
202 | |
203 | package WHATEVER; |
805232b4 |
204 | foo WHATEVER "works"; |
a0d0e21e |
205 | |
58e0a6ae |
206 | # |
207 | # test the \(@foo) construct |
208 | # |
209 | package main; |
fb53bbb2 |
210 | @foo = \(1..3); |
58e0a6ae |
211 | @bar = \(@foo); |
212 | @baz = \(1,@foo,@bar); |
805232b4 |
213 | is (scalar (@bar), 3); |
214 | is (scalar grep(ref($_), @bar), 3); |
215 | is (scalar (@baz), 3); |
58e0a6ae |
216 | |
fb53bbb2 |
217 | my(@fuu) = \(1..2,3); |
58e0a6ae |
218 | my(@baa) = \(@fuu); |
219 | my(@bzz) = \(1,@fuu,@baa); |
805232b4 |
220 | is (scalar (@baa), 3); |
221 | is (scalar grep(ref($_), @baa), 3); |
222 | is (scalar (@bzz), 3); |
58e0a6ae |
223 | |
75ea820e |
224 | # also, it can't be an lvalue |
225 | eval '\\($x, $y) = (1, 2);'; |
805232b4 |
226 | like ($@, qr/Can\'t modify.*ref.*in.*assignment/); |
75ea820e |
227 | |
bc44cdaf |
228 | # test for proper destruction of lexical objects |
1c509eb9 |
229 | $test = curr_test(); |
805232b4 |
230 | sub larry::DESTROY { print "# larry\nok $test\n"; } |
231 | sub curly::DESTROY { print "# curly\nok ", $test + 1, "\n"; } |
232 | sub moe::DESTROY { print "# moe\nok ", $test + 2, "\n"; } |
bc44cdaf |
233 | |
234 | { |
235 | my ($joe, @curly, %larry); |
236 | my $moe = bless \$joe, 'moe'; |
237 | my $curly = bless \@curly, 'curly'; |
238 | my $larry = bless \%larry, 'larry'; |
239 | print "# leaving block\n"; |
240 | } |
241 | |
242 | print "# left block\n"; |
805232b4 |
243 | curr_test($test + 3); |
bc44cdaf |
244 | |
fb73857a |
245 | # another glob test |
246 | |
805232b4 |
247 | |
248 | $foo = "garbage"; |
fb73857a |
249 | { local(*bar) = "foo" } |
805232b4 |
250 | $bar = "glob 3"; |
fb73857a |
251 | local(*bar) = *bar; |
805232b4 |
252 | is ($bar, "glob 3"); |
fb73857a |
253 | |
805232b4 |
254 | $var = "glob 4"; |
d4010388 |
255 | $_ = \$var; |
805232b4 |
256 | is ($$_, 'glob 4'); |
d4010388 |
257 | |
4e8e7886 |
258 | |
805232b4 |
259 | # test if reblessing during destruction results in more destruction |
260 | $test = curr_test(); |
4e8e7886 |
261 | { |
262 | package A; |
263 | sub new { bless {}, shift } |
805232b4 |
264 | DESTROY { print "# destroying 'A'\nok ", $test + 1, "\n" } |
8bac7e00 |
265 | package _B; |
4e8e7886 |
266 | sub new { bless {}, shift } |
805232b4 |
267 | DESTROY { print "# destroying '_B'\nok $test\n"; bless shift, 'A' } |
4e8e7886 |
268 | package main; |
8bac7e00 |
269 | my $b = _B->new; |
4e8e7886 |
270 | } |
805232b4 |
271 | curr_test($test + 2); |
4e8e7886 |
272 | |
273 | # test if $_[0] is properly protected in DESTROY() |
274 | |
275 | { |
805232b4 |
276 | my $test = curr_test(); |
4e8e7886 |
277 | my $i = 0; |
278 | local $SIG{'__DIE__'} = sub { |
279 | my $m = shift; |
280 | if ($i++ > 4) { |
805232b4 |
281 | print "# infinite recursion, bailing\nnot ok $test\n"; |
4e8e7886 |
282 | exit 1; |
283 | } |
805232b4 |
284 | like ($m, qr/^Modification of a read-only/); |
4e8e7886 |
285 | }; |
286 | package C; |
287 | sub new { bless {}, shift } |
288 | DESTROY { $_[0] = 'foo' } |
289 | { |
290 | print "# should generate an error...\n"; |
291 | my $c = C->new; |
292 | } |
293 | print "# good, didn't recurse\n"; |
294 | } |
295 | |
0dd88869 |
296 | # test if refgen behaves with autoviv magic |
0dd88869 |
297 | { |
298 | my @a; |
805232b4 |
299 | $a[1] = "good"; |
300 | my $got; |
301 | for (@a) { |
302 | $got .= ${\$_}; |
303 | $got .= ';'; |
304 | } |
305 | is ($got, ";good;"); |
0dd88869 |
306 | } |
307 | |
840a7b70 |
308 | # This test is the reason for postponed destruction in sv_unref |
309 | $a = [1,2,3]; |
310 | $a = $a->[1]; |
805232b4 |
311 | is ($a, 2); |
840a7b70 |
312 | |
04ca4930 |
313 | # This test used to coredump. The BEGIN block is important as it causes the |
314 | # op that created the constant reference to be freed. Hence the only |
315 | # reference to the constant string "pass" is in $a. The hack that made |
316 | # sure $a = $a->[1] would work didn't work with references to constants. |
317 | |
04ca4930 |
318 | |
319 | foreach my $lexical ('', 'my $a; ') { |
320 | my $expect = "pass\n"; |
321 | my $result = runperl (switches => ['-wl'], stderr => 1, |
322 | prog => $lexical . 'BEGIN {$a = \q{pass}}; $a = $$a; print $a'); |
323 | |
805232b4 |
324 | is ($?, 0); |
325 | is ($result, $expect); |
840a7b70 |
326 | } |
327 | |
805232b4 |
328 | my $test = curr_test(); |
04ca4930 |
329 | sub x::DESTROY {print "ok ", $test + shift->[0], "\n"} |
330 | { my $a1 = bless [3],"x"; |
331 | my $a2 = bless [2],"x"; |
332 | { my $a3 = bless [1],"x"; |
333 | my $a4 = bless [0],"x"; |
334 | 567; |
335 | } |
336 | } |
805232b4 |
337 | curr_test($test+4); |
338 | |
339 | is (runperl (switches=>['-l'], |
340 | prog=> 'print 1; print qq-*$\*-;print 1;'), |
341 | "1\n*\n*\n1\n"); |
b2ce0fda |
342 | |
39cff0d9 |
343 | # bug #21347 |
344 | |
345 | runperl(prog => 'sub UNIVERSAL::AUTOLOAD { qr// } a->p' ); |
805232b4 |
346 | is ($?, 0, 'UNIVERSAL::AUTOLOAD called when freeing qr//'); |
39cff0d9 |
347 | |
7b102d90 |
348 | runperl(prog => 'sub UNIVERSAL::DESTROY { warn } bless \$a, A', stderr => 1); |
805232b4 |
349 | is ($?, 0, 'warn called inside UNIVERSAL::DESTROY'); |
7b102d90 |
350 | |
23bb1b96 |
351 | |
352 | # bug #22719 |
353 | |
354 | runperl(prog => 'sub f { my $x = shift; *z = $x; } f({}); f();'); |
805232b4 |
355 | is ($?, 0, 'coredump on typeglob = (SvRV && !SvROK)'); |
23bb1b96 |
356 | |
ec5f3c78 |
357 | # bug #27268: freeing self-referential typeglobs could trigger |
358 | # "Attempt to free unreferenced scalar" warnings |
359 | |
805232b4 |
360 | is (runperl( |
ec5f3c78 |
361 | prog => 'use Symbol;my $x=bless \gensym,"t"; print;*$$x=$x', |
362 | stderr => 1 |
805232b4 |
363 | ), '', 'freeing self-referential typeglob'); |
23bb1b96 |
364 | |
804ffa60 |
365 | # using a regex in the destructor for STDOUT segfaulted because the |
366 | # REGEX pad had already been freed (ithreads build only). The |
367 | # object is required to trigger the early freeing of GV refs to to STDOUT |
368 | |
805232b4 |
369 | like (runperl( |
804ffa60 |
370 | prog => '$x=bless[]; sub IO::Handle::DESTROY{$_="bad";s/bad/ok/;print}', |
371 | stderr => 1 |
805232b4 |
372 | ), qr/^(ok)+$/, 'STDOUT destructor'); |
804ffa60 |
373 | |
805232b4 |
374 | # Bit of a hack to make test.pl happy. There are 3 more tests after it leaves. |
375 | $test = curr_test(); |
376 | curr_test($test + 3); |
4e8e7886 |
377 | # test global destruction |
378 | |
840a7b70 |
379 | my $test1 = $test + 1; |
380 | my $test2 = $test + 2; |
381 | |
8990e307 |
382 | package FINALE; |
383 | |
384 | { |
840a7b70 |
385 | $ref3 = bless ["ok $test2\n"]; # package destruction |
386 | my $ref2 = bless ["ok $test1\n"]; # lexical destruction |
387 | local $ref1 = bless ["ok $test\n"]; # dynamic destruction |
8990e307 |
388 | 1; # flush any temp values on stack |
389 | } |
390 | |
391 | DESTROY { |
392 | print $_[0][0]; |
393 | } |
804ffa60 |
394 | |