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';
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});
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)
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;
'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 .= <BAR>;
+ 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 /,
-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;'
"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
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
https://perl5.git.perl.org / perl5.git / blobdiff