X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/0fbaa0e5e2fb0ff6f79a72915095a1325ebcd12e..95a2e48fd5a4c8e221149d1c1de129f30eaeadce:/t/op/gv.t diff --git a/t/op/gv.t b/t/op/gv.t index 804ddd6..081d280 100644 --- a/t/op/gv.t +++ b/t/op/gv.t @@ -6,13 +6,13 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); } use warnings; -plan( tests => 256 ); +plan( tests => 271 ); # type coercion on assignment $foo = 'foo'; @@ -200,18 +200,6 @@ is *x{PACKAGE}, 'main', 'and *foo{PACKAGE} the original package'; my $a = "SYM000"; ok(!defined *{$a}); - { - no warnings 'deprecated'; - ok(!defined @{$a}); - } - ok(!defined *{$a}); - - { - no warnings 'deprecated'; - ok(!defined %{$a}); - } - ok(!defined *{$a}); - ok(!defined ${$a}); ok(!defined *{$a}); @@ -502,6 +490,9 @@ is join("-", eval "&yarrow(1..10)"), '4-5-6', 'const list ignores & args'; is prototype "yarrow", "", 'const list has "" prototype'; is eval "yarrow", 3, 'const list in scalar cx returns length'; +$::{borage} = \&ok; +eval 'borage("sub ref in stash")' or fail "sub ref in stash"; + { use vars qw($glook $smek $foof); # Check reference assignment isn't affected by the SV type (bug #38439) @@ -524,7 +515,7 @@ is eval "yarrow", 3, 'const list in scalar cx returns length'; format = . -foreach my $value ({1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) { +foreach my $value ({1=>2}, *STDOUT{IO}, *STDOUT{FORMAT}) { # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns # IO::Handle, which isn't what we want. my $type = $value; @@ -947,6 +938,78 @@ ok eval { 'no error when gp_free calls a destructor that assigns to the gv'; } +# This is a similar test, for destructors seeing a GV without a reference +# count on its gp. +sub undefine_me_if_you_dare {} +bless \&undefine_me_if_you_dare, "Undefiner"; +sub Undefiner::DESTROY { + undef *undefine_me_if_you_dare; +} +{ + my $w; + local $SIG{__WARN__} = sub { $w .= shift }; + undef *undefine_me_if_you_dare; + is $w, undef, + 'undeffing a gv in DESTROY triggered by undeffing the same gv' +} + +# [perl #121242] +# More gp_free madness. gp_free could call a destructor that frees the gv +# whose gp is being freed. +sub Fred::AUTOLOAD { $Fred::AUTOLOAD } +undef *{"Fred::AUTOLOAD"}; +pass 'no crash from gp_free triggering gv_try_downgrade'; +sub _121242::DESTROY { delete $_121242::{$_[0][0]} }; +${"_121242::foo"} = bless ["foo"], _121242::; +undef *{"_121242::foo"}; +pass 'no crash from pp_undef/gp_free freeing the gv'; +${"_121242::bar"} = bless ["bar"], _121242::; +*{"_121242::bar"} = "bar"; +pass 'no crash from sv_setsv/gp_free freeing the gv'; +${"_121242::baz"} = bless ["baz"], _121242::; +*{"_121242::baz"} = *foo; +pass 'no crash from glob_assign_glob/gp_free freeing the gv'; +{ + my $foo; + undef *_121242::DESTROY; + *_121242::DESTROY = sub { undef $foo }; + my $set_up_foo = sub { + # Make $$foo into a fake glob whose array slot holds a blessed + # array that undefines $foo, freeing the fake glob. + $foo = undef; + $$foo = do {local *bar}; + *$$foo = bless [], _121242::; + }; + &$set_up_foo; + $$foo = 3; + pass 'no crash from sv_setsv/sv_unglob/gp_free freeing the gv'; + &$set_up_foo; + utf8::encode $$foo; + pass 'no crash from sv_utf8_encode/sv_unglob/gp_free freeing the gv'; + &$set_up_foo; + open BAR, "TEST"; + $$foo .= ; + pass 'no crash from do_readline/sv_unglob/gp_free freeing the gv'; + close BAR; + &$set_up_foo; + $$foo .= 3; + pass 'no crash from pp_concat/sv_unglob/gp_free freeing the gv'; + &$set_up_foo; + no warnings; + $$foo++; + pass 'no crash from sv_inc/sv_unglob/gp_free freeing the gv'; + &$set_up_foo; + $$foo--; + pass 'no crash from sv_dec/sv_unglob/gp_free freeing the gv'; + &$set_up_foo; + undef $$foo; + pass 'no crash from pp_undef/sv_unglob/gp_free freeing the gv'; + $foo = undef; + $$foo = 3; + $$foo =~ s/3/$$foo = do {local *bar}; *$$foo = bless [],_121242::; 4/e; + pass 'no crash from pp_substcont/sv_unglob/gp_free freeing the gv'; +} + # *{undef} eval { *{my $undef} = 3 }; like $@, qr/^Can't use an undefined value as a symbol reference at /, @@ -986,6 +1049,10 @@ package lrcg { -T _; is "$!",$bang, 'try_downgrade does not touch PL_statgv (last stat handle)'; + readline *{"try_downgrade2"}; + my $lastfh = "${^LAST_FH}"; + eval "*try_downgrade2 if 0"; + is ${^LAST_FH}, $lastfh, 'try_downgrade does not touch PL_last_in_gv'; } is runperl(prog => '$s = STDERR; close $s; undef *$s;' @@ -993,6 +1060,33 @@ is runperl(prog => '$s = STDERR; close $s; undef *$s;' "Warning: something's wrong at -e line 1.\n", "try_downgrade does not touch PL_stderrgv"; +is runperl(prog => + 'use constant foo=>1; BEGIN { $x = \&foo } undef &$x; $x->()', + stderr=>1), + "Undefined subroutine &main::foo called at -e line 1.\n", + "gv_try_downgrade does not anonymise CVs referenced elsewhere"; + +package glob_constant_test { + sub foo { 42 } + use constant bar => *foo; + BEGIN { undef *foo } + ::is eval { bar->() }, eval { &{+bar} }, + 'glob_constant->() is not mangled at compile time'; + ::is "$@", "", 'no error from eval { &{+glob_constant} }'; +} + +{ + my $free2; + local $SIG{__WARN__} = sub { ++$free2 if shift =~ /Attempt to free/ }; + my $handleref; + my $proxy = \$handleref; + open $$proxy, "TEST"; + delete $::{*$handleref{NAME}}; # delete *main::_GEN_xxx + undef $handleref; + is $free2, undef, + 'no double free because of bad rv2gv/newGVgen refcounting'; +} + # Look away, please. # This violates perl's internal structures by fiddling with stashes in a # way that should never happen, but perl should not start trying to free @@ -1017,6 +1111,15 @@ undef $::{_119051again}; # CvGV, it still gets a fake one eval { $y->() }; pass "No crash due to CvGV pointing to glob copy in the stash"; +# Aliasing should disable no-common-vars optimisation. +{ + *x = *y; + $x = 3; + ($x, my $z) = (1, $y); + is $z, 3, 'list assignment after aliasing [perl #89646]'; +} + + __END__ Perl Rules