Commit | Line | Data |
---|---|---|
79072805 LW |
1 | #!./perl |
2 | ||
20274adc JH |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
1ae3d757 | 5 | require './test.pl'; |
624c42e2 | 6 | set_up_inc( qw(. ../lib) ); |
20274adc JH |
7 | } |
8 | ||
e24631be | 9 | use strict qw(refs subs); |
79072805 | 10 | |
7aab773a | 11 | plan(257); |
805232b4 | 12 | |
1d51ab6c FC |
13 | # Test this first before we extend the stack with other operations. |
14 | # This caused an asan failure due to a bad write past the end of the stack. | |
15 | eval { die 1..127, $_=\() }; | |
16 | ||
79072805 LW |
17 | # Test glob operations. |
18 | ||
1c509eb9 NC |
19 | $bar = "one"; |
20 | $foo = "two"; | |
79072805 LW |
21 | { |
22 | local(*foo) = *bar; | |
1c509eb9 | 23 | is($foo, 'one'); |
79072805 | 24 | } |
1c509eb9 | 25 | is ($foo, 'two'); |
79072805 | 26 | |
1c509eb9 NC |
27 | $baz = "three"; |
28 | $foo = "four"; | |
79072805 LW |
29 | { |
30 | local(*foo) = 'baz'; | |
1c509eb9 | 31 | is ($foo, 'three'); |
79072805 | 32 | } |
1c509eb9 | 33 | is ($foo, 'four'); |
79072805 | 34 | |
1c509eb9 | 35 | $foo = "global"; |
79072805 LW |
36 | { |
37 | local(*foo); | |
1c509eb9 NC |
38 | is ($foo, undef); |
39 | $foo = "local"; | |
40 | is ($foo, 'local'); | |
79072805 | 41 | } |
1c509eb9 | 42 | is ($foo, 'global'); |
79072805 | 43 | |
e24631be NC |
44 | { |
45 | no strict 'refs'; | |
79072805 LW |
46 | # Test fake references. |
47 | ||
e24631be NC |
48 | $baz = "valid"; |
49 | $bar = 'baz'; | |
50 | $foo = 'bar'; | |
51 | is ($$$foo, 'valid'); | |
52 | } | |
79072805 LW |
53 | |
54 | # Test real references. | |
55 | ||
56 | $FOO = \$BAR; | |
57 | $BAR = \$BAZ; | |
1c509eb9 NC |
58 | $BAZ = "hit"; |
59 | is ($$$FOO, 'hit'); | |
79072805 LW |
60 | |
61 | # Test references to real arrays. | |
62 | ||
1c509eb9 NC |
63 | my $test = curr_test(); |
64 | @ary = ($test,$test+1,$test+2,$test+3); | |
79072805 LW |
65 | $ref[0] = \@a; |
66 | $ref[1] = \@b; | |
67 | $ref[2] = \@c; | |
68 | $ref[3] = \@d; | |
69 | for $i (3,1,2,0) { | |
70 | push(@{$ref[$i]}, "ok $ary[$i]\n"); | |
71 | } | |
72 | print @a; | |
73 | print ${$ref[1]}[0]; | |
74 | print @{$ref[2]}[0]; | |
e24631be NC |
75 | { |
76 | no strict 'refs'; | |
77 | print @{'d'}; | |
78 | } | |
1c509eb9 | 79 | curr_test($test+4); |
79072805 LW |
80 | |
81 | # Test references to references. | |
82 | ||
83 | $refref = \\$x; | |
1c509eb9 NC |
84 | $x = "Good"; |
85 | is ($$$refref, 'Good'); | |
79072805 | 86 | |
26321c2d | 87 | # Test nested anonymous arrays. |
79072805 LW |
88 | |
89 | $ref = [[],2,[3,4,5,]]; | |
1c509eb9 NC |
90 | is (scalar @$ref, 3); |
91 | is ($$ref[1], 2); | |
92 | is (${$$ref[2]}[2], 5); | |
93 | is (scalar @{$$ref[0]}, 0); | |
79072805 | 94 | |
1c509eb9 NC |
95 | is ($ref->[1], 2); |
96 | is ($ref->[2]->[0], 3); | |
79072805 LW |
97 | |
98 | # Test references to hashes of references. | |
99 | ||
100 | $refref = \%whatever; | |
101 | $refref->{"key"} = $ref; | |
1c509eb9 | 102 | is ($refref->{"key"}->[2]->[0], 3); |
79072805 | 103 | |
93a17b20 | 104 | # Test to see if anonymous subarrays spring into existence. |
79072805 LW |
105 | |
106 | $spring[5]->[0] = 123; | |
107 | $spring[5]->[1] = 456; | |
108 | push(@{$spring[5]}, 789); | |
1c509eb9 | 109 | is (join(':',@{$spring[5]}), "123:456:789"); |
79072805 | 110 | |
93a17b20 | 111 | # Test to see if anonymous subhashes spring into existence. |
79072805 LW |
112 | |
113 | @{$spring2{"foo"}} = (1,2,3); | |
114 | $spring2{"foo"}->[3] = 4; | |
1c509eb9 | 115 | is (join(':',@{$spring2{"foo"}}), "1:2:3:4"); |
79072805 LW |
116 | |
117 | # Test references to subroutines. | |
118 | ||
1c509eb9 NC |
119 | { |
120 | my $called; | |
121 | sub mysub { $called++; } | |
122 | $subref = \&mysub; | |
123 | &$subref; | |
124 | is ($called, 1); | |
125 | } | |
03002e3e | 126 | is ref eval {\&{""}}, "CODE", 'reference to &{""} [perl #94476]'; |
63aab7ec FC |
127 | delete $My::{"Foo::"}; |
128 | is ref \&My::Foo::foo, "CODE", | |
129 | 'creating stub with \&deleted_stash::foo [perl #128532]'; | |
130 | ||
79072805 | 131 | |
e47aeb22 FC |
132 | # Test references to return values of operators (TARGs/PADTMPs) |
133 | { | |
134 | my @refs; | |
135 | for("a", "b") { | |
136 | push @refs, \"$_" | |
137 | } | |
138 | is join(" ", map $$_, @refs), "a b", 'refgen+PADTMP'; | |
139 | } | |
140 | ||
79072805 | 141 | $subrefref = \\&mysub2; |
1c509eb9 NC |
142 | is ($$subrefref->("GOOD"), "good"); |
143 | sub mysub2 { lc shift } | |
79072805 | 144 | |
f0826785 BM |
145 | # Test REGEXP assignment |
146 | ||
293c724a NC |
147 | SKIP: { |
148 | skip_if_miniperl("no dynamic loading on miniperl, so can't load re", 5); | |
149 | require re; | |
f0826785 BM |
150 | my $x = qr/x/; |
151 | my $str = "$x"; # regex stringification may change | |
152 | ||
153 | my $y = $$x; | |
154 | is ($y, $str, "bare REGEXP stringifies correctly"); | |
155 | ok (eval { "x" =~ $y }, "bare REGEXP matches correctly"); | |
156 | ||
157 | my $z = \$y; | |
158 | ok (re::is_regexp($z), "new ref to REXEXP passes is_regexp"); | |
159 | is ($z, $str, "new ref to REGEXP stringifies correctly"); | |
160 | ok (eval { "x" =~ $z }, "new ref to REGEXP matches correctly"); | |
161 | } | |
162 | { | |
163 | my ($x, $str); | |
164 | { | |
165 | my $y = qr/x/; | |
166 | $str = "$y"; | |
167 | $x = $$y; | |
168 | } | |
169 | is ($x, $str, "REGEXP keeps a ref to its mother_re"); | |
170 | ok (eval { "x" =~ $x }, "REGEXP with mother_re still matches"); | |
171 | } | |
172 | ||
e344d7db JK |
173 | # test dereferencing errors |
174 | { | |
175 | format STDERR = | |
176 | . | |
177 | my $ref; | |
178 | foreach $ref (*STDOUT{IO}, *STDERR{FORMAT}) { | |
179 | eval q/ $$ref /; | |
180 | like($@, qr/Not a SCALAR reference/, "Scalar dereference"); | |
181 | eval q/ @$ref /; | |
182 | like($@, qr/Not an ARRAY reference/, "Array dereference"); | |
183 | eval q/ %$ref /; | |
184 | like($@, qr/Not a HASH reference/, "Hash dereference"); | |
185 | eval q/ &$ref /; | |
186 | like($@, qr/Not a CODE reference/, "Code dereference"); | |
187 | } | |
188 | ||
189 | $ref = *STDERR{FORMAT}; | |
190 | eval q/ *$ref /; | |
191 | like($@, qr/Not a GLOB reference/, "Glob dereference"); | |
192 | ||
193 | $ref = *STDOUT{IO}; | |
194 | eval q/ *$ref /; | |
195 | is($@, '', "Glob dereference of PVIO is acceptable"); | |
196 | ||
197 | is($ref, *{$ref}{IO}, "IO slot of the temporary glob is set correctly"); | |
198 | } | |
199 | ||
79072805 LW |
200 | # Test the ref operator. |
201 | ||
6e592b3a BM |
202 | sub PVBM () { 'foo' } |
203 | { my $dummy = index 'foo', PVBM } | |
204 | ||
205 | my $pviv = 1; "$pviv"; | |
206 | my $pvnv = 1.0; "$pvnv"; | |
207 | my $x; | |
208 | ||
209 | # we don't test | |
210 | # tied lvalue => SCALAR, as we haven't tested tie yet | |
211 | # BIND, 'cos we can't create them yet | |
212 | # REGEXP, 'cos that requires overload or Scalar::Util | |
6e592b3a BM |
213 | |
214 | for ( | |
215 | [ 'undef', SCALAR => \undef ], | |
216 | [ 'constant IV', SCALAR => \1 ], | |
217 | [ 'constant NV', SCALAR => \1.0 ], | |
218 | [ 'constant PV', SCALAR => \'f' ], | |
219 | [ 'scalar', SCALAR => \$x ], | |
220 | [ 'PVIV', SCALAR => \$pviv ], | |
221 | [ 'PVNV', SCALAR => \$pvnv ], | |
222 | [ 'PVMG', SCALAR => \$0 ], | |
223 | [ 'PVBM', SCALAR => \PVBM ], | |
544303ee FC |
224 | [ 'scalar @array', SCALAR => \scalar @array ], |
225 | [ 'scalar %hash', SCALAR => \scalar %hash ], | |
6e592b3a BM |
226 | [ 'vstring', VSTRING => \v1 ], |
227 | [ 'ref', REF => \\1 ], | |
7393165e FC |
228 | [ 'substr lvalue', LVALUE => \substr($x, 0, 0) ], |
229 | [ 'pos lvalue', LVALUE => \pos ], | |
230 | [ 'vec lvalue', LVALUE => \vec($x,0,1) ], | |
6e592b3a BM |
231 | [ 'named array', ARRAY => \@ary ], |
232 | [ 'anon array', ARRAY => [ 1 ] ], | |
233 | [ 'named hash', HASH => \%whatever ], | |
234 | [ 'anon hash', HASH => { a => 1 } ], | |
235 | [ 'named sub', CODE => \&mysub, ], | |
236 | [ 'anon sub', CODE => sub { 1; } ], | |
237 | [ 'glob', GLOB => \*foo ], | |
238 | [ 'format', FORMAT => *STDERR{FORMAT} ], | |
239 | ) { | |
240 | my ($desc, $type, $ref) = @$_; | |
241 | is (ref $ref, $type, "ref() for ref to $desc"); | |
242 | like ("$ref", qr/^$type\(0x[0-9a-f]+\)$/, "stringify for ref to $desc"); | |
243 | } | |
244 | ||
d963bf01 NC |
245 | is (ref *STDOUT{IO}, 'IO::File', 'IO refs are blessed into IO::File'); |
246 | like (*STDOUT{IO}, qr/^IO::File=IO\(0x[0-9a-f]+\)$/, | |
6e592b3a | 247 | 'stringify for IO refs'); |
79072805 | 248 | |
b535e014 FC |
249 | { # Test re-use of ref's TARG [perl #101738] |
250 | my $obj = bless [], '____'; | |
251 | my $uniobj = bless [], chr 256; | |
252 | my $get_ref = sub { ref shift }; | |
253 | my $dummy = &$get_ref($uniobj); | |
254 | $dummy = &$get_ref($obj); | |
255 | ok exists { ____ => undef }->{$dummy}, 'ref sets UTF8 flag correctly'; | |
256 | } | |
257 | ||
79072805 LW |
258 | # Test anonymous hash syntax. |
259 | ||
260 | $anonhash = {}; | |
1c509eb9 | 261 | is (ref $anonhash, 'HASH'); |
7aab773a LM |
262 | |
263 | # GH #21478 | |
264 | $anonhash = { 'one' }; | |
265 | is scalar keys %$anonhash, 1, 'single value in anonhash creates a key (count)'; | |
266 | ok exists $anonhash->{one}, 'single value in anonhash creates a key (existence)'; | |
267 | is $anonhash->{one}, undef, 'single value in anonhash creates a key (value)'; | |
268 | ||
e24631be | 269 | $anonhash2 = {FOO => 'BAR', ABC => 'XYZ',}; |
1c509eb9 | 270 | is (join('', sort values %$anonhash2), 'BARXYZ'); |
79072805 LW |
271 | |
272 | # Test bless operator. | |
273 | ||
274 | package MYHASH; | |
7e2d91e6 TC |
275 | { |
276 | no warnings qw(syntax deprecated); | |
277 | $object = bless $main'anonhash2; | |
278 | } | |
1c509eb9 NC |
279 | main::is (ref $object, 'MYHASH'); |
280 | main::is ($object->{ABC}, 'XYZ'); | |
79072805 LW |
281 | |
282 | $object2 = bless {}; | |
1c509eb9 | 283 | main::is (ref $object2, 'MYHASH'); |
79072805 LW |
284 | |
285 | # Test ordinary call on object method. | |
286 | ||
1c509eb9 | 287 | &mymethod($object,"argument"); |
79072805 LW |
288 | |
289 | sub mymethod { | |
290 | local($THIS, @ARGS) = @_; | |
ed6116ce | 291 | die 'Got a "' . ref($THIS). '" instead of a MYHASH' |
e24631be | 292 | unless ref $THIS eq 'MYHASH'; |
1c509eb9 NC |
293 | main::is ($ARGS[0], "argument"); |
294 | main::is ($THIS->{FOO}, 'BAR'); | |
79072805 LW |
295 | } |
296 | ||
297 | # Test automatic destructor call. | |
298 | ||
1c509eb9 | 299 | $string = "bad"; |
79072805 | 300 | $object = "foo"; |
1c509eb9 | 301 | $string = "good"; |
7e2d91e6 TC |
302 | { |
303 | no warnings qw(syntax deprecated); | |
304 | $main'anonhash2 = "foo"; | |
305 | } | |
8990e307 | 306 | $string = ""; |
79072805 | 307 | |
ed6116ce | 308 | DESTROY { |
8990e307 | 309 | return unless $string; |
1c509eb9 | 310 | main::is ($string, 'good'); |
79072805 | 311 | |
a0d0e21e | 312 | # Test that the object has not already been "cursed". |
1c509eb9 | 313 | main::isnt (ref shift, 'HASH'); |
79072805 LW |
314 | } |
315 | ||
316 | # Now test inheritance of methods. | |
317 | ||
318 | package OBJ; | |
319 | ||
e24631be | 320 | @ISA = ('BASEOBJ'); |
79072805 | 321 | |
7e2d91e6 TC |
322 | { |
323 | no warnings qw(syntax deprecated); | |
324 | $main'object = bless {FOO => 'foo', BAR => 'bar'}; | |
325 | } | |
79072805 LW |
326 | |
327 | package main; | |
328 | ||
329 | # Test arrow-style method invocation. | |
330 | ||
e24631be | 331 | is ($object->doit("BAR"), 'bar'); |
79072805 LW |
332 | |
333 | # Test indirect-object-style method invocation. | |
334 | ||
335 | $foo = doit $object "FOO"; | |
e24631be | 336 | main::is ($foo, 'foo'); |
79072805 | 337 | |
7e2d91e6 TC |
338 | { |
339 | no warnings qw(syntax deprecated); | |
340 | sub BASEOBJ'doit { | |
341 | local $ref = shift; | |
342 | die "Not an OBJ" unless ref $ref eq 'OBJ'; | |
343 | $ref->{shift()}; | |
344 | } | |
79072805 | 345 | } |
8990e307 | 346 | |
a0d0e21e LW |
347 | package UNIVERSAL; |
348 | @ISA = 'LASTCHANCE'; | |
349 | ||
350 | package LASTCHANCE; | |
805232b4 | 351 | sub foo { main::is ($_[1], 'works') } |
a0d0e21e LW |
352 | |
353 | package WHATEVER; | |
805232b4 | 354 | foo WHATEVER "works"; |
a0d0e21e | 355 | |
58e0a6ae GS |
356 | # |
357 | # test the \(@foo) construct | |
358 | # | |
359 | package main; | |
fb53bbb2 | 360 | @foo = \(1..3); |
58e0a6ae GS |
361 | @bar = \(@foo); |
362 | @baz = \(1,@foo,@bar); | |
805232b4 NC |
363 | is (scalar (@bar), 3); |
364 | is (scalar grep(ref($_), @bar), 3); | |
365 | is (scalar (@baz), 3); | |
58e0a6ae | 366 | |
fb53bbb2 | 367 | my(@fuu) = \(1..2,3); |
58e0a6ae GS |
368 | my(@baa) = \(@fuu); |
369 | my(@bzz) = \(1,@fuu,@baa); | |
805232b4 NC |
370 | is (scalar (@baa), 3); |
371 | is (scalar grep(ref($_), @baa), 3); | |
372 | is (scalar (@bzz), 3); | |
58e0a6ae | 373 | |
75ea820e | 374 | # also, it can't be an lvalue |
217e3565 | 375 | # (That’s what *you* think! --sprout) |
75ea820e | 376 | eval '\\($x, $y) = (1, 2);'; |
217e3565 | 377 | like ($@, qr/Can\'t modify.*ref.*in.*assignment(?x: |
baabe3fb | 378 | )|Experimental aliasing via reference not enabled/); |
75ea820e | 379 | |
bc44cdaf | 380 | # test for proper destruction of lexical objects |
1c509eb9 | 381 | $test = curr_test(); |
805232b4 NC |
382 | sub larry::DESTROY { print "# larry\nok $test\n"; } |
383 | sub curly::DESTROY { print "# curly\nok ", $test + 1, "\n"; } | |
384 | sub moe::DESTROY { print "# moe\nok ", $test + 2, "\n"; } | |
bc44cdaf GS |
385 | |
386 | { | |
387 | my ($joe, @curly, %larry); | |
388 | my $moe = bless \$joe, 'moe'; | |
389 | my $curly = bless \@curly, 'curly'; | |
390 | my $larry = bless \%larry, 'larry'; | |
391 | print "# leaving block\n"; | |
392 | } | |
393 | ||
394 | print "# left block\n"; | |
805232b4 | 395 | curr_test($test + 3); |
bc44cdaf | 396 | |
fb73857a | 397 | # another glob test |
398 | ||
805232b4 NC |
399 | |
400 | $foo = "garbage"; | |
fb73857a | 401 | { local(*bar) = "foo" } |
805232b4 | 402 | $bar = "glob 3"; |
fb73857a | 403 | local(*bar) = *bar; |
805232b4 | 404 | is ($bar, "glob 3"); |
fb73857a | 405 | |
805232b4 | 406 | $var = "glob 4"; |
d4010388 | 407 | $_ = \$var; |
805232b4 | 408 | is ($$_, 'glob 4'); |
d4010388 | 409 | |
4e8e7886 | 410 | |
805232b4 NC |
411 | # test if reblessing during destruction results in more destruction |
412 | $test = curr_test(); | |
4e8e7886 GS |
413 | { |
414 | package A; | |
415 | sub new { bless {}, shift } | |
805232b4 | 416 | DESTROY { print "# destroying 'A'\nok ", $test + 1, "\n" } |
8bac7e00 | 417 | package _B; |
4e8e7886 | 418 | sub new { bless {}, shift } |
805232b4 | 419 | DESTROY { print "# destroying '_B'\nok $test\n"; bless shift, 'A' } |
4e8e7886 | 420 | package main; |
8bac7e00 | 421 | my $b = _B->new; |
4e8e7886 | 422 | } |
805232b4 | 423 | curr_test($test + 2); |
4e8e7886 GS |
424 | |
425 | # test if $_[0] is properly protected in DESTROY() | |
426 | ||
427 | { | |
805232b4 | 428 | my $test = curr_test(); |
4e8e7886 GS |
429 | my $i = 0; |
430 | local $SIG{'__DIE__'} = sub { | |
431 | my $m = shift; | |
432 | if ($i++ > 4) { | |
805232b4 | 433 | print "# infinite recursion, bailing\nnot ok $test\n"; |
4e8e7886 GS |
434 | exit 1; |
435 | } | |
805232b4 | 436 | like ($m, qr/^Modification of a read-only/); |
4e8e7886 GS |
437 | }; |
438 | package C; | |
439 | sub new { bless {}, shift } | |
440 | DESTROY { $_[0] = 'foo' } | |
441 | { | |
442 | print "# should generate an error...\n"; | |
443 | my $c = C->new; | |
444 | } | |
445 | print "# good, didn't recurse\n"; | |
446 | } | |
447 | ||
5e307270 FC |
448 | # test that DESTROY is called on all objects during global destruction, |
449 | # even those without hard references [perl #36347] | |
450 | ||
451 | is( | |
452 | runperl( | |
c1b879e5 | 453 | stderr => 1, prog => 'sub DESTROY { print qq-aaa\n- } bless \$a[0]' |
5e307270 | 454 | ), |
c1b879e5 | 455 | "aaa\n", 'DESTROY called on array elem' |
5e307270 FC |
456 | ); |
457 | is( | |
458 | runperl( | |
459 | stderr => 1, | |
c1b879e5 | 460 | prog => '{ bless \my@x; *a=sub{@x}}sub DESTROY { print qq-aaa\n- }' |
5e307270 | 461 | ), |
c1b879e5 | 462 | "aaa\n", |
5e307270 FC |
463 | 'DESTROY called on closure variable' |
464 | ); | |
640c0c3e | 465 | |
f6f93f80 FC |
466 | # But cursing objects must not result in double frees |
467 | # This caused "Attempt to free unreferenced scalar" in 5.16. | |
468 | fresh_perl_is( | |
469 | 'bless \%foo::, bar::; bless \%bar::, foo::; print "ok\n"', "ok\n", | |
470 | { stderr => 1 }, | |
471 | 'no double free when stashes are blessed into each other'); | |
472 | ||
5e307270 | 473 | |
0dd88869 | 474 | # test if refgen behaves with autoviv magic |
0dd88869 GS |
475 | { |
476 | my @a; | |
805232b4 NC |
477 | $a[1] = "good"; |
478 | my $got; | |
479 | for (@a) { | |
480 | $got .= ${\$_}; | |
481 | $got .= ';'; | |
482 | } | |
483 | is ($got, ";good;"); | |
0dd88869 GS |
484 | } |
485 | ||
840a7b70 IZ |
486 | # This test is the reason for postponed destruction in sv_unref |
487 | $a = [1,2,3]; | |
488 | $a = $a->[1]; | |
805232b4 | 489 | is ($a, 2); |
840a7b70 | 490 | |
04ca4930 NC |
491 | # This test used to coredump. The BEGIN block is important as it causes the |
492 | # op that created the constant reference to be freed. Hence the only | |
493 | # reference to the constant string "pass" is in $a. The hack that made | |
494 | # sure $a = $a->[1] would work didn't work with references to constants. | |
495 | ||
04ca4930 NC |
496 | |
497 | foreach my $lexical ('', 'my $a; ') { | |
498 | my $expect = "pass\n"; | |
499 | my $result = runperl (switches => ['-wl'], stderr => 1, | |
500 | prog => $lexical . 'BEGIN {$a = \q{pass}}; $a = $$a; print $a'); | |
501 | ||
805232b4 NC |
502 | is ($?, 0); |
503 | is ($result, $expect); | |
840a7b70 IZ |
504 | } |
505 | ||
e24631be | 506 | $test = curr_test(); |
04ca4930 NC |
507 | sub x::DESTROY {print "ok ", $test + shift->[0], "\n"} |
508 | { my $a1 = bless [3],"x"; | |
509 | my $a2 = bless [2],"x"; | |
510 | { my $a3 = bless [1],"x"; | |
511 | my $a4 = bless [0],"x"; | |
512 | 567; | |
513 | } | |
514 | } | |
805232b4 NC |
515 | curr_test($test+4); |
516 | ||
517 | is (runperl (switches=>['-l'], | |
518 | prog=> 'print 1; print qq-*$\*-;print 1;'), | |
519 | "1\n*\n*\n1\n"); | |
b2ce0fda | 520 | |
39cff0d9 AE |
521 | # bug #21347 |
522 | ||
523 | runperl(prog => 'sub UNIVERSAL::AUTOLOAD { qr// } a->p' ); | |
805232b4 | 524 | is ($?, 0, 'UNIVERSAL::AUTOLOAD called when freeing qr//'); |
39cff0d9 | 525 | |
7b102d90 | 526 | runperl(prog => 'sub UNIVERSAL::DESTROY { warn } bless \$a, A', stderr => 1); |
805232b4 | 527 | is ($?, 0, 'warn called inside UNIVERSAL::DESTROY'); |
7b102d90 | 528 | |
23bb1b96 DM |
529 | |
530 | # bug #22719 | |
531 | ||
532 | runperl(prog => 'sub f { my $x = shift; *z = $x; } f({}); f();'); | |
805232b4 | 533 | is ($?, 0, 'coredump on typeglob = (SvRV && !SvROK)'); |
23bb1b96 | 534 | |
ec5f3c78 DM |
535 | # bug #27268: freeing self-referential typeglobs could trigger |
536 | # "Attempt to free unreferenced scalar" warnings | |
537 | ||
805232b4 | 538 | is (runperl( |
3d7a9343 | 539 | prog => 'use Symbol;my $x=bless \gensym,q{t}; print;*$$x=$x', |
ec5f3c78 | 540 | stderr => 1 |
805232b4 | 541 | ), '', 'freeing self-referential typeglob'); |
23bb1b96 | 542 | |
804ffa60 DM |
543 | # using a regex in the destructor for STDOUT segfaulted because the |
544 | # REGEX pad had already been freed (ithreads build only). The | |
a3815e44 | 545 | # object is required to trigger the early freeing of GV refs to STDOUT |
804ffa60 | 546 | |
ff26e4c8 CB |
547 | TODO: { |
548 | local $TODO = "works but output through pipe is mangled" if $^O eq 'VMS'; | |
549 | like (runperl( | |
3d7a9343 | 550 | prog => '$x=bless[]; sub IO::Handle::DESTROY{$_=q{bad};s/bad/ok/;print}', |
ff26e4c8 CB |
551 | stderr => 1 |
552 | ), qr/^(ok)+$/, 'STDOUT destructor'); | |
553 | } | |
804ffa60 | 554 | |
2e434a10 | 555 | { |
512d1826 NC |
556 | no strict 'refs'; |
557 | $name8 = chr 163; | |
558 | $name_utf8 = $name8 . chr 256; | |
559 | chop $name_utf8; | |
560 | ||
561 | is ($$name8, undef, 'Nothing before we start'); | |
562 | is ($$name_utf8, undef, 'Nothing before we start'); | |
563 | $$name8 = "Pound"; | |
564 | is ($$name8, "Pound", 'Accessing via 8 bit symref works'); | |
512d1826 NC |
565 | is ($$name_utf8, "Pound", 'Accessing via UTF8 symref works'); |
566 | } | |
567 | ||
2e434a10 | 568 | { |
512d1826 NC |
569 | no strict 'refs'; |
570 | $name_utf8 = $name = chr 9787; | |
571 | utf8::encode $name_utf8; | |
572 | ||
573 | is (length $name, 1, "Name is 1 char"); | |
574 | is (length $name_utf8, 3, "UTF8 representation is 3 chars"); | |
575 | ||
576 | is ($$name, undef, 'Nothing before we start'); | |
577 | is ($$name_utf8, undef, 'Nothing before we start'); | |
578 | $$name = "Face"; | |
579 | is ($$name, "Face", 'Accessing via Unicode symref works'); | |
512d1826 NC |
580 | is ($$name_utf8, undef, |
581 | 'Accessing via the UTF8 byte sequence gives nothing'); | |
582 | } | |
583 | ||
431529db | 584 | { |
512d1826 NC |
585 | no strict 'refs'; |
586 | $name1 = "\0Chalk"; | |
587 | $name2 = "\0Cheese"; | |
588 | ||
589 | isnt ($name1, $name2, "They differ"); | |
590 | ||
431529db | 591 | is ($$name1, undef, 'Nothing before we start (scalars)'); |
512d1826 | 592 | is ($$name2, undef, 'Nothing before we start'); |
b3d904f3 | 593 | $$name1 = "Yummy"; |
512d1826 | 594 | is ($$name1, "Yummy", 'Accessing via the correct name works'); |
512d1826 NC |
595 | is ($$name2, undef, |
596 | 'Accessing via a different NUL-containing name gives nothing'); | |
fc4809d7 NC |
597 | # defined uses a different code path |
598 | ok (defined $$name1, 'defined via the correct name works'); | |
599 | ok (!defined $$name2, | |
600 | 'defined via a different NUL-containing name gives nothing'); | |
431529db NC |
601 | |
602 | is ($name1->[0], undef, 'Nothing before we start (arrays)'); | |
603 | is ($name2->[0], undef, 'Nothing before we start'); | |
604 | $name1->[0] = "Yummy"; | |
605 | is ($name1->[0], "Yummy", 'Accessing via the correct name works'); | |
606 | is ($name2->[0], undef, | |
607 | 'Accessing via a different NUL-containing name gives nothing'); | |
fc4809d7 NC |
608 | ok (defined $name1->[0], 'defined via the correct name works'); |
609 | ok (!defined$name2->[0], | |
610 | 'defined via a different NUL-containing name gives nothing'); | |
431529db NC |
611 | |
612 | my (undef, $one) = @{$name1}[2,3]; | |
613 | my (undef, $two) = @{$name2}[2,3]; | |
614 | is ($one, undef, 'Nothing before we start (array slices)'); | |
615 | is ($two, undef, 'Nothing before we start'); | |
616 | @{$name1}[2,3] = ("Very", "Yummy"); | |
617 | (undef, $one) = @{$name1}[2,3]; | |
618 | (undef, $two) = @{$name2}[2,3]; | |
619 | is ($one, "Yummy", 'Accessing via the correct name works'); | |
620 | is ($two, undef, | |
621 | 'Accessing via a different NUL-containing name gives nothing'); | |
fc4809d7 NC |
622 | ok (defined $one, 'defined via the correct name works'); |
623 | ok (!defined $two, | |
624 | 'defined via a different NUL-containing name gives nothing'); | |
431529db NC |
625 | |
626 | is ($name1->{PWOF}, undef, 'Nothing before we start (hashes)'); | |
627 | is ($name2->{PWOF}, undef, 'Nothing before we start'); | |
628 | $name1->{PWOF} = "Yummy"; | |
629 | is ($name1->{PWOF}, "Yummy", 'Accessing via the correct name works'); | |
630 | is ($name2->{PWOF}, undef, | |
631 | 'Accessing via a different NUL-containing name gives nothing'); | |
fc4809d7 NC |
632 | ok (defined $name1->{PWOF}, 'defined via the correct name works'); |
633 | ok (!defined $name2->{PWOF}, | |
634 | 'defined via a different NUL-containing name gives nothing'); | |
431529db NC |
635 | |
636 | my (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'}; | |
637 | my (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'}; | |
638 | is ($one, undef, 'Nothing before we start (hash slices)'); | |
639 | is ($two, undef, 'Nothing before we start'); | |
640 | @{$name1}{'SNIF', 'BEEYOOP'} = ("Very", "Yummy"); | |
641 | (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'}; | |
642 | (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'}; | |
643 | is ($one, "Yummy", 'Accessing via the correct name works'); | |
644 | is ($two, undef, | |
645 | 'Accessing via a different NUL-containing name gives nothing'); | |
fc4809d7 NC |
646 | ok (defined $one, 'defined via the correct name works'); |
647 | ok (!defined $two, | |
648 | 'defined via a different NUL-containing name gives nothing'); | |
431529db NC |
649 | |
650 | $name1 = "Left"; $name2 = "Left\0Right"; | |
651 | my $glob2 = *{$name2}; | |
652 | ||
88e5f542 | 653 | is ($glob1, undef, "We get different typeglobs. In fact, undef"); |
780a5241 NC |
654 | |
655 | *{$name1} = sub {"One"}; | |
656 | *{$name2} = sub {"Two"}; | |
657 | ||
658 | is (&{$name1}, "One"); | |
659 | is (&{$name2}, "Two"); | |
512d1826 NC |
660 | } |
661 | ||
9a9798c2 YST |
662 | # test derefs after list slice |
663 | ||
664 | is ( ({foo => "bar"})[0]{foo}, "bar", 'hash deref from list slice w/o ->' ); | |
665 | is ( ({foo => "bar"})[0]->{foo}, "bar", 'hash deref from list slice w/ ->' ); | |
666 | is ( ([qw/foo bar/])[0][1], "bar", 'array deref from list slice w/o ->' ); | |
667 | is ( ([qw/foo bar/])[0]->[1], "bar", 'array deref from list slice w/ ->' ); | |
668 | is ( (sub {"bar"})[0](), "bar", 'code deref from list slice w/o ->' ); | |
669 | is ( (sub {"bar"})[0]->(), "bar", 'code deref from list slice w/ ->' ); | |
670 | ||
671 | # deref on empty list shouldn't autovivify | |
672 | { | |
673 | local $@; | |
674 | eval { ()[0]{foo} }; | |
aaa63dae | 675 | like ( "$@", qr/Can't use an undefined value as a HASH reference/, |
9a9798c2 YST |
676 | "deref of undef from list slice fails" ); |
677 | } | |
678 | ||
6e592b3a BM |
679 | # these will segfault if they fail |
680 | ||
681 | my $pvbm = PVBM; | |
682 | my $rpvbm = \$pvbm; | |
683 | ||
684 | ok (!eval { *$rpvbm }, 'PVBM ref is not a GLOB ref'); | |
685 | ok (!eval { *$pvbm }, 'PVBM is not a GLOB ref'); | |
686 | ok (!eval { $$pvbm }, 'PVBM is not a SCALAR ref'); | |
687 | ok (!eval { @$pvbm }, 'PVBM is not an ARRAY ref'); | |
688 | ok (!eval { %$pvbm }, 'PVBM is not a HASH ref'); | |
689 | ok (!eval { $pvbm->() }, 'PVBM is not a CODE ref'); | |
690 | ok (!eval { $rpvbm->foo }, 'PVBM is not an object'); | |
691 | ||
fcf99ed4 B |
692 | # bug 24254 |
693 | is( runperl(stderr => 1, prog => 'map eval qq(exit),1 for 1'), ""); | |
694 | is( runperl(stderr => 1, prog => 'eval { for (1) { map { die } 2 } };'), ""); | |
695 | is( runperl(stderr => 1, prog => 'for (125) { map { exit } (213)}'), ""); | |
54c717c3 CB |
696 | my $hushed = $^O eq 'VMS' ? 'use vmsish qw(hushed);' : ''; |
697 | is( runperl(stderr => 1, prog => $hushed . 'map die,4 for 3'), "Died at -e line 1.\n"); | |
698 | is( runperl(stderr => 1, prog => $hushed . 'grep die,4 for 3'), "Died at -e line 1.\n"); | |
699 | is( runperl(stderr => 1, prog => $hushed . 'for $a (3) {@b=sort {die} 4,5}'), "Died at -e line 1.\n"); | |
fcf99ed4 B |
700 | |
701 | # bug 57564 | |
702 | is( runperl(stderr => 1, prog => 'my $i;for $i (1) { for $i (2) { } }'), ""); | |
703 | ||
57ef47cc DM |
704 | # The mechanism for freeing objects in globs used to leave dangling |
705 | # pointers to freed SVs. To test this, we construct this nested structure: | |
706 | # GV => blessed(AV) => RV => GV => blessed(SV) | |
707 | # all with a refcnt of 1, and hope that the second GV gets processed first | |
708 | # by do_clean_named_objs. Then when the first GV is processed, it mustn't | |
93f09d7b | 709 | # find anything nasty left by the previous GV processing. |
57ef47cc DM |
710 | # The eval is stop things in the main body of the code holding a reference |
711 | # to a GV, and the print at the end seems to bee necessary to ensure | |
712 | # the correct freeing order of *x and *y (no, I don't know why - DAPM). | |
713 | ||
714 | is (runperl( | |
715 | prog => 'eval q[bless \@y; bless \$x; $y[0] = \*x; $z = \*y; ]; ' | |
bf70f410 | 716 | . 'delete $::{x}; delete $::{y}; print qq{ok\n};', |
57ef47cc DM |
717 | stderr => 1), |
718 | "ok\n", 'freeing freed glob in global destruction'); | |
719 | ||
fcf99ed4 | 720 | |
fd1d9b5c FC |
721 | # Test undefined hash references as arguments to %{} in boolean context |
722 | # [perl #81750] | |
723 | { | |
724 | no strict 'refs'; | |
725 | eval { my $foo; %$foo; }; ok !$@, '%$undef'; | |
726 | eval { my $foo; scalar %$foo; }; ok !$@, 'scalar %$undef'; | |
727 | eval { my $foo; !%$foo; }; ok !$@, '!%$undef'; | |
728 | eval { my $foo; if ( %$foo) {} }; ok !$@, 'if ( %$undef) {}'; | |
729 | eval { my $foo; if (!%$foo) {} }; ok !$@, 'if (!%$undef) {}'; | |
730 | eval { my $foo; unless ( %$foo) {} }; ok !$@, 'unless ( %$undef) {}'; | |
731 | eval { my $foo; unless (!%$foo) {} }; ok !$@, 'unless (!%$undef) {}'; | |
732 | eval { my $foo; 1 if %$foo; }; ok !$@, '1 if %$undef'; | |
733 | eval { my $foo; 1 if !%$foo; }; ok !$@, '1 if !%$undef'; | |
734 | eval { my $foo; 1 unless %$foo; }; ok !$@, '1 unless %$undef;'; | |
735 | eval { my $foo; 1 unless ! %$foo; }; ok !$@, '1 unless ! %$undef'; | |
736 | eval { my $foo; %$foo ? 1 : 0; }; ok !$@, ' %$undef ? 1 : 0'; | |
737 | eval { my $foo; !%$foo ? 1 : 0; }; ok !$@, '!%$undef ? 1 : 0'; | |
738 | } | |
739 | ||
da0c0b27 DM |
740 | # RT #88330 |
741 | # Make sure that a leaked thinggy with multiple weak references to | |
742 | # it doesn't trigger a panic with multiple rounds of global cleanup | |
743 | # (Perl_sv_clean_all). | |
744 | ||
8d55e914 | 745 | { |
da0c0b27 DM |
746 | local $ENV{PERL_DESTRUCT_LEVEL} = 2; |
747 | ||
748 | # we do all permutations of array/hash, 1ref/2ref, to account | |
749 | # for the different way backref magic is stored | |
750 | ||
751 | fresh_perl_is(<<'EOF', 'ok', { stderr => 1 }, 'array with 1 weak ref'); | |
e678439a | 752 | no warnings 'experimental::builtin'; |
8d55e914 | 753 | use builtin qw(weaken); |
da0c0b27 DM |
754 | my $r = []; |
755 | Internals::SvREFCNT(@$r, 9); | |
756 | my $r1 = $r; | |
757 | weaken($r1); | |
758 | print "ok"; | |
759 | EOF | |
760 | ||
761 | fresh_perl_is(<<'EOF', 'ok', { stderr => 1 }, 'array with 2 weak refs'); | |
e678439a | 762 | no warnings 'experimental::builtin'; |
8d55e914 | 763 | use builtin qw(weaken); |
da0c0b27 DM |
764 | my $r = []; |
765 | Internals::SvREFCNT(@$r, 9); | |
766 | my $r1 = $r; | |
767 | weaken($r1); | |
768 | my $r2 = $r; | |
769 | weaken($r2); | |
770 | print "ok"; | |
771 | EOF | |
772 | ||
773 | fresh_perl_is(<<'EOF', 'ok', { stderr => 1 }, 'hash with 1 weak ref'); | |
e678439a | 774 | no warnings 'experimental::builtin'; |
8d55e914 | 775 | use builtin qw(weaken); |
da0c0b27 DM |
776 | my $r = {}; |
777 | Internals::SvREFCNT(%$r, 9); | |
778 | my $r1 = $r; | |
779 | weaken($r1); | |
780 | print "ok"; | |
781 | EOF | |
782 | ||
783 | fresh_perl_is(<<'EOF', 'ok', { stderr => 1 }, 'hash with 2 weak refs'); | |
e678439a | 784 | no warnings 'experimental::builtin'; |
8d55e914 | 785 | use builtin qw(weaken); |
da0c0b27 DM |
786 | my $r = {}; |
787 | Internals::SvREFCNT(%$r, 9); | |
788 | my $r1 = $r; | |
789 | weaken($r1); | |
790 | my $r2 = $r; | |
791 | weaken($r2); | |
792 | print "ok"; | |
793 | EOF | |
794 | ||
795 | } | |
fd1d9b5c | 796 | |
8d55e914 | 797 | { |
5d4ff231 FC |
798 | my $error; |
799 | *hassgropper::DESTROY = sub { | |
e678439a | 800 | no warnings 'experimental::builtin'; |
8d55e914 PE |
801 | use builtin qw(weaken); |
802 | eval { weaken($_[0]) }; | |
5d4ff231 FC |
803 | $error = $@; |
804 | # This line caused a crash before weaken refused to weaken a | |
805 | # read-only reference: | |
806 | $do::not::overwrite::this = $_[0]; | |
807 | }; | |
808 | my $xs = bless [], "hassgropper"; | |
809 | undef $xs; | |
810 | like $error, qr/^Modification of a read-only/, | |
811 | 'weaken refuses to weaken a read-only ref'; | |
812 | # Now that the test has passed, avoid sabotaging global destruction: | |
813 | undef *hassgropper::DESTROY; | |
814 | undef $do::not::overwrite::this; | |
815 | } | |
816 | ||
817 | ||
a15456de BF |
818 | is ref( bless {}, "nul\0clean" ), "nul\0clean", "ref() is nul-clean"; |
819 | ||
8ffa04e0 FC |
820 | # Test constants and references thereto. |
821 | for (3) { | |
822 | eval { $_ = 4 }; | |
823 | like $@, qr/^Modification of a read-only/, | |
824 | 'assignment to value aliased to literal number'; | |
8ffa04e0 FC |
825 | eval { ${\$_} = 4 }; |
826 | like $@, qr/^Modification of a read-only/, | |
827 | 'refgen does not allow assignment to value aliased to literal number'; | |
828 | } | |
829 | for ("4eounthouonth") { | |
830 | eval { $_ = 4 }; | |
831 | like $@, qr/^Modification of a read-only/, | |
832 | 'assignment to value aliased to literal string'; | |
8ffa04e0 FC |
833 | eval { ${\$_} = 4 }; |
834 | like $@, qr/^Modification of a read-only/, | |
835 | 'refgen does not allow assignment to value aliased to literal string'; | |
836 | } | |
deea21e7 | 837 | { |
deea21e7 FC |
838 | my $aref = \123; |
839 | is \$$aref, $aref, | |
840 | '[perl #109746] referential identity of \literal under threads+mad' | |
841 | } | |
8ffa04e0 | 842 | |
ba75e9a4 DM |
843 | # ref in boolean context |
844 | { | |
845 | my $false = 0; | |
846 | my $true = 1; | |
847 | my $plain = []; | |
848 | my $obj = bless {}, "Foo"; | |
849 | my $objnull = bless [], ""; | |
850 | my $obj0 = bless [], "0"; | |
851 | my $obj00 = bless [], "00"; | |
852 | my $obj1 = bless [], "1"; | |
853 | ||
854 | is !ref $false, 1, '!ref $false'; | |
855 | is !ref $true, 1, '!ref $true'; | |
856 | is !ref $plain, "", '!ref $plain'; | |
857 | is !ref $obj, "", '!ref $obj'; | |
858 | is !ref $objnull, "", '!ref $objnull'; | |
859 | is !ref $obj0 , 1, '!ref $obj0'; | |
860 | is !ref $obj00, "", '!ref $obj00'; | |
861 | is !ref $obj1, "", '!ref $obj1'; | |
862 | ||
863 | is ref $obj || 0, "Foo", 'ref $obj || 0'; | |
864 | is ref $obj // 0, "Foo", 'ref $obj // 0'; | |
865 | is $true && ref $obj, "Foo", '$true && ref $obj'; | |
866 | is ref $obj ? "true" : "false", "true", 'ref $obj ? "true" : "false"'; | |
867 | ||
868 | my $r = 2; | |
869 | if (ref $obj) { $r = 1 }; | |
870 | is $r, 1, 'if (ref $obj)'; | |
871 | ||
872 | $r = 2; | |
873 | if (ref $obj0) { $r = 1 }; | |
874 | is $r, 2, 'if (ref $obj0)'; | |
875 | ||
876 | $r = 2; | |
877 | if (ref $obj) { $r = 1 } else { $r = 0 }; | |
878 | is $r, 1, 'if (ref $obj) else'; | |
879 | ||
880 | $r = 2; | |
881 | if (ref $obj0) { $r = 1 } else { $r = 0 }; | |
882 | is $r, 0, 'if (ref $obj0) else'; | |
883 | } | |
884 | ||
02960b52 DM |
885 | { |
886 | # RT #78288 | |
887 | # if an op returns &PL_sv_zero rather than newSViv(0), the | |
888 | # value should be mutable. So ref (via the PADTMP flag) should | |
889 | # make a mutable copy | |
890 | ||
891 | my @a = (); | |
892 | my $r = \ scalar grep $_ == 1, @a; | |
893 | $$r += 10; | |
894 | is $$r, 10, "RT #78288 - mutable PL_sv_zero copy"; | |
895 | } | |
896 | ||
ba75e9a4 | 897 | |
655f5b26 DM |
898 | # RT#130861: heap-use-after-free in pp_rv2sv, from asan fuzzing |
899 | SKIP: { | |
900 | skip_if_miniperl("no dynamic loading on miniperl, so can't load arybase", 1); | |
901 | # this value is critical - its just enough so that the stack gets | |
902 | # grown which loading/calling arybase | |
903 | my $n = 125; | |
904 | ||
905 | my $code = <<'EOF'; | |
906 | $ary = '['; | |
907 | my @a = map $$ary, 1..NNN; | |
908 | print "@a\n"; | |
909 | EOF | |
910 | $code =~ s/NNN/$n/g; | |
911 | my @exp = ("0") x $n; | |
912 | fresh_perl_is($code, "@exp", { stderr => 1 }, | |
913 | 'rt#130861: heap uaf in pp_rv2sv'); | |
914 | } | |
915 | ||
805232b4 NC |
916 | # Bit of a hack to make test.pl happy. There are 3 more tests after it leaves. |
917 | $test = curr_test(); | |
918 | curr_test($test + 3); | |
4e8e7886 GS |
919 | # test global destruction |
920 | ||
840a7b70 IZ |
921 | my $test1 = $test + 1; |
922 | my $test2 = $test + 2; | |
923 | ||
8990e307 LW |
924 | package FINALE; |
925 | ||
926 | { | |
840a7b70 IZ |
927 | $ref3 = bless ["ok $test2\n"]; # package destruction |
928 | my $ref2 = bless ["ok $test1\n"]; # lexical destruction | |
929 | local $ref1 = bless ["ok $test\n"]; # dynamic destruction | |
8990e307 LW |
930 | 1; # flush any temp values on stack |
931 | } | |
932 | ||
933 | DESTROY { | |
934 | print $_[0][0]; | |
935 | } | |
804ffa60 | 936 |