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