use warnings;
require './test.pl';
-plan( tests => 68 );
+plan( tests => 132 );
# type coersion on assignment
$foo = 'foo';
{
my $w = '';
- $SIG{__WARN__} = sub { $w = $_[0] };
+ local $SIG{__WARN__} = sub { $w = $_[0] };
sub abc1 ();
local *abc1 = sub { };
is ($w, '');
}
{
- my $output = runperl(prog => <<'EOPROG', stderr => 1);
+ # Need some sort of die or warn to get the global destruction text if the
+ # bug is still present
+ my $output = runperl(prog => <<'EOPROG');
package M;
-sub DESTROY {warn "Farewell $_[0]"}
+$| = 1;
+sub DESTROY {eval {die qq{Farewell $_[0]}}; print $@}
package main;
bless \$A::B, 'M';
unlike($output, qr/global destruction/,
"unreferenced symbol tables should be cleaned up immediately");
}
+
+# Possibly not the correct test file for these tests.
+# There are certain space optimisations implemented via promotion rules to
+# GVs
+
+foreach (qw (oonk ga_shloip)) {
+ ok(!exists $::{$_}, "no symbols of any sort to start with for $_");
+}
+
+# A string in place of the typeglob is promoted to the function prototype
+$::{oonk} = "pie";
+my $proto = eval 'prototype \&oonk';
+die if $@;
+is ($proto, "pie", "String is promoted to prototype");
+
+
+# A reference to a value is used to generate a constant subroutine
+foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2},
+ \*STDIN, \&ok, \undef, *STDOUT) {
+ delete $::{oonk};
+ $::{oonk} = \$value;
+ $proto = eval 'prototype \&oonk';
+ die if $@;
+ is ($proto, '', "Prototype for a constant subroutine is empty");
+
+ my $got = eval 'oonk';
+ die if $@;
+ is (ref $got, ref $value, "Correct type of value (" . ref($value) . ")");
+ is ($got, $value, "Value is correctly set");
+}
+
+delete $::{oonk};
+$::{oonk} = \"Value";
+
+*{"ga_shloip"} = \&{"oonk"};
+
+is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is");
+is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
+is (eval 'ga_shloip', "Value", "Constant has correct value");
+is (ref $::{ga_shloip}, 'SCALAR',
+ "Inlining of constant doesn't change represenatation");
+
+delete $::{ga_shloip};
+
+eval 'sub ga_shloip (); 1' or die $@;
+is ($::{ga_shloip}, '', "Prototype is stored as an empty string");
+
+# Check that a prototype expands.
+*{"ga_shloip"} = \&{"oonk"};
+
+is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
+is (eval 'ga_shloip', "Value", "Constant has correct value");
+is (ref \$::{ga_shloip}, 'GLOB', "Symbol table has full typeglob");
+
+
+@::zwot = ('Zwot!');
+
+# Check that assignment to an existing typeglob works
+{
+ my $w = '';
+ local $SIG{__WARN__} = sub { $w = $_[0] };
+ *{"zwot"} = \&{"oonk"};
+ is($w, '', "Should be no warning");
+}
+
+is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
+is (eval 'zwot', "Value", "Constant has correct value");
+is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob");
+is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob");
+
+sub spritsits () {
+ "Traditional";
+}
+
+# Check that assignment to an existing subroutine works
+{
+ my $w = '';
+ local $SIG{__WARN__} = sub { $w = $_[0] };
+ *{"spritsits"} = \&{"oonk"};
+ like($w, qr/^Constant subroutine main::spritsits redefined/,
+ "Redefining a constant sub should warn");
+}
+
+is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
+is (eval 'spritsits', "Value", "Constant has correct value");
+is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob");
+
+my $result;
+# Check that assignment to an existing typeglob works
+{
+ my $w = '';
+ local $SIG{__WARN__} = sub { $w = $_[0] };
+ $result = *{"plunk"} = \&{"oonk"};
+ is($w, '', "Should be no warning");
+}
+
+is (ref \$result, 'GLOB',
+ "Non void assignment should still return a typeglob");
+
+is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
+is (eval 'plunk', "Value", "Constant has correct value");
+is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
+
+my $gr = eval '\*plunk' or die;
+
+{
+ my $w = '';
+ local $SIG{__WARN__} = sub { $w = $_[0] };
+ $result = *{$gr} = \&{"oonk"};
+ like($w, qr/^Constant subroutine main::plunk redefined/,
+ "Redefining a constant sub should warn");
+}
+
+is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
+is (eval 'plunk', "Value", "Constant has correct value");
+is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
+
+format =
+.
+
+foreach my $value ([1,2,3], {1=>2}, *STDOUT{IO}, \&ok, *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;
+ $type =~ s/.*=//;
+ $type =~ s/\(.*//;
+ delete $::{oonk};
+ $::{oonk} = $value;
+ $proto = eval 'prototype \&oonk';
+ like ($@, qr/^Cannot convert a reference to $type to typeglob/,
+ "Cannot upgrade ref-to-$type to typeglob");
+}
__END__
Perl
Rules