summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorJesse Luehrs <doy@tozt.net>2010-10-31 11:04:51 -0500
committerJesse Luehrs <doy@tozt.net>2010-10-31 11:04:51 -0500
commitdc378b60e595186cddf0b2ce35da3e6749022770 (patch)
treedd667f647877f1f4518c2caab8550b29022ad75e
parentc7f0ea46eaf630b6660e32d2cc5e7a9759bb46cf (diff)
downloadpackage-stash-dc378b60e595186cddf0b2ce35da3e6749022770.tar.gz
package-stash-dc378b60e595186cddf0b2ce35da3e6749022770.zip
Revert "revert vivication changes for now again"
This reverts commit 67b1704808e62f27210fe992df9c45b232fe9d5b. Conflicts: Changes
-rw-r--r--inc/MMPackageStash.pm4
-rw-r--r--lib/Package/Stash.pm51
-rw-r--r--t/04-get.t144
-rw-r--r--t/05-isa.t2
4 files changed, 172 insertions, 29 deletions
diff --git a/inc/MMPackageStash.pm b/inc/MMPackageStash.pm
index cab44dc..93c04e4 100644
--- a/inc/MMPackageStash.pm
+++ b/inc/MMPackageStash.pm
@@ -14,8 +14,8 @@ around _build_MakeFile_PL_template => sub {
$template .= <<'CHECK_CONFLICTS';
sub check_conflicts {
my %conflicts = (
- # 'Class::MOP' => '1.08',
- # 'MooseX::Role::WithOverloading' => '0.08',
+ 'Class::MOP' => '1.08',
+ 'MooseX::Role::WithOverloading' => '0.08',
);
my $found = 0;
for my $mod ( sort keys %conflicts ) {
diff --git a/lib/Package/Stash.pm b/lib/Package/Stash.pm
index 32e5d30..6c361c1 100644
--- a/lib/Package/Stash.pm
+++ b/lib/Package/Stash.pm
@@ -5,6 +5,10 @@ use warnings;
use Carp qw(confess);
use Scalar::Util qw(reftype);
+use Symbol;
+# before 5.12, assigning to the ISA glob would make it lose its magical ->isa
+# powers
+use constant BROKEN_ISA_ASSIGNMENT => ($] < 5.012);
=head1 SYNOPSIS
@@ -230,21 +234,42 @@ sub get_package_symbol {
my $namespace = $self->namespace;
if (!exists $namespace->{$name}) {
- # assigning to the result of this function like
- # @{$stash->get_package_symbol('@ISA')} = @new_ISA
- # makes the result not visible until the variable is explicitly
- # accessed... in the case of @ISA, this might never happen
- # for instance, assigning like that and then calling $obj->isa
- # will fail. see t/005-isa.t
- if ($opts{vivify} && $type eq 'ARRAY' && $name ne 'ISA') {
- $self->add_package_symbol($variable, []);
- }
- elsif ($opts{vivify} && $type eq 'HASH') {
- $self->add_package_symbol($variable, {});
+ if ($opts{vivify}) {
+ if ($type eq 'ARRAY') {
+ if (BROKEN_ISA_ASSIGNMENT) {
+ $self->add_package_symbol(
+ $variable,
+ $name eq 'ISA' ? () : ([])
+ );
+ }
+ else {
+ $self->add_package_symbol($variable, []);
+ }
+ }
+ elsif ($type eq 'HASH') {
+ $self->add_package_symbol($variable, {});
+ }
+ elsif ($type eq 'SCALAR') {
+ $self->add_package_symbol($variable);
+ }
+ elsif ($type eq 'IO') {
+ $self->add_package_symbol($variable, Symbol::geniosym);
+ }
+ elsif ($type eq 'CODE') {
+ confess "Don't know how to vivify CODE variables";
+ }
+ else {
+ confess "Unknown type $type in vivication";
+ }
}
else {
- # FIXME
- $self->add_package_symbol($variable)
+ if ($type eq 'CODE') {
+ # this effectively "de-vivifies" the code slot. if we don't do
+ # this, referencing the coderef at the end of this function
+ # will cause perl to auto-vivify a stub coderef in the slot,
+ # which isn't what we want
+ $self->add_package_symbol($variable);
+ }
}
}
diff --git a/t/04-get.t b/t/04-get.t
index ebeb864..3c4ae43 100644
--- a/t/04-get.t
+++ b/t/04-get.t
@@ -7,60 +7,178 @@ use Package::Stash;
{
BEGIN {
- my $stash = Package::Stash->new('Foo');
+ my $stash = Package::Stash->new('Hash');
my $val = $stash->get_package_symbol('%foo');
is($val, undef, "got nothing yet");
}
{
no warnings 'void', 'once';
- %Foo::foo;
+ %Hash::foo;
}
BEGIN {
- my $stash = Package::Stash->new('Foo');
+ my $stash = Package::Stash->new('Hash');
my $val = $stash->get_package_symbol('%foo');
is(ref($val), 'HASH', "got something");
$val->{bar} = 1;
is_deeply($stash->get_package_symbol('%foo'), {bar => 1},
- "got the right variable");
+ "got the right variable");
+ is_deeply(\%Hash::foo, {bar => 1},
+ "stash has the right variable");
}
}
{
BEGIN {
- my $stash = Package::Stash->new('Bar');
+ my $stash = Package::Stash->new('Array');
my $val = $stash->get_package_symbol('@foo');
- is($val, undef, "got something");
+ is($val, undef, "got nothing yet");
}
{
no warnings 'void', 'once';
- @Bar::foo;
+ @Array::foo;
}
BEGIN {
- my $stash = Package::Stash->new('Bar');
+ my $stash = Package::Stash->new('Array');
my $val = $stash->get_package_symbol('@foo');
is(ref($val), 'ARRAY', "got something");
push @$val, 1;
is_deeply($stash->get_package_symbol('@foo'), [1],
- "got the right variable");
+ "got the right variable");
+ is_deeply(\@Array::foo, [1],
+ "stash has the right variable");
+ }
+}
+
+{
+ BEGIN {
+ my $stash = Package::Stash->new('Scalar');
+ my $val = $stash->get_package_symbol('$foo');
+ is($val, undef, "got nothing yet");
+ }
+ {
+ no warnings 'void', 'once';
+ $Scalar::foo;
+ }
+ BEGIN {
+ my $stash = Package::Stash->new('Scalar');
+ my $val = $stash->get_package_symbol('$foo');
+ is(ref($val), 'SCALAR', "got something");
+ $$val = 1;
+ is_deeply($stash->get_package_symbol('$foo'), \1,
+ "got the right variable");
+ is($Scalar::foo, 1,
+ "stash has the right variable");
+ }
+}
+
+{
+ BEGIN {
+ my $stash = Package::Stash->new('Code');
+ my $val = $stash->get_package_symbol('&foo');
+ is($val, undef, "got nothing yet");
+ }
+ {
+ no warnings 'void', 'once';
+ sub Code::foo { }
+ }
+ BEGIN {
+ my $stash = Package::Stash->new('Code');
+ my $val = $stash->get_package_symbol('&foo');
+ is(ref($val), 'CODE', "got something");
+ is(prototype($val), undef, "got the right variable");
+ &Scalar::Util::set_prototype($val, '&');
+ is($stash->get_package_symbol('&foo'), $val,
+ "got the right variable");
+ is(prototype($stash->get_package_symbol('&foo')), '&',
+ "got the right variable");
+ is(prototype(\&Code::foo), '&',
+ "stash has the right variable");
+ }
+}
+
+{
+ BEGIN {
+ my $stash = Package::Stash->new('Io');
+ my $val = $stash->get_package_symbol('FOO');
+ is($val, undef, "got nothing yet");
+ }
+ {
+ no warnings 'void', 'once';
+ package Io;
+ fileno(FOO);
+ }
+ BEGIN {
+ my $stash = Package::Stash->new('Io');
+ my $val = $stash->get_package_symbol('FOO');
+ isa_ok($val, 'IO');
+ my $str = "foo";
+ open $val, '<', \$str;
+ is(readline($stash->get_package_symbol('FOO')), "foo",
+ "got the right variable");
+ seek($stash->get_package_symbol('FOO'), 0, 0);
+ {
+ package Io;
+ ::isa_ok(*FOO{IO}, 'IO');
+ ::is(<FOO>, "foo",
+ "stash has the right variable");
+ }
}
}
{
- my $stash = Package::Stash->new('Baz');
+ my $stash = Package::Stash->new('Hash::Vivify');
my $val = $stash->get_or_add_package_symbol('%foo');
is(ref($val), 'HASH', "got something");
$val->{bar} = 1;
is_deeply($stash->get_or_add_package_symbol('%foo'), {bar => 1},
- "got the right variable");
+ "got the right variable");
+ no warnings 'once';
+ is_deeply(\%Hash::Vivify::foo, {bar => 1},
+ "stash has the right variable");
}
{
- my $stash = Package::Stash->new('Quux');
+ my $stash = Package::Stash->new('Array::Vivify');
my $val = $stash->get_or_add_package_symbol('@foo');
is(ref($val), 'ARRAY', "got something");
push @$val, 1;
is_deeply($stash->get_or_add_package_symbol('@foo'), [1],
- "got the right variable");
+ "got the right variable");
+ no warnings 'once';
+ is_deeply(\@Array::Vivify::foo, [1],
+ "stash has the right variable");
+}
+
+{
+ my $stash = Package::Stash->new('Scalar::Vivify');
+ my $val = $stash->get_or_add_package_symbol('$foo');
+ is(ref($val), 'SCALAR', "got something");
+ $$val = 1;
+ is_deeply($stash->get_or_add_package_symbol('$foo'), \1,
+ "got the right variable");
+ no warnings 'once';
+ is($Scalar::Vivify::foo, 1,
+ "stash has the right variable");
+}
+
+{
+ BEGIN {
+ my $stash = Package::Stash->new('Io::Vivify');
+ my $val = $stash->get_or_add_package_symbol('FOO');
+ isa_ok($val, 'IO');
+ my $str = "foo";
+ open $val, '<', \$str;
+ is(readline($stash->get_package_symbol('FOO')), "foo",
+ "got the right variable");
+ seek($stash->get_package_symbol('FOO'), 0, 0);
+ }
+ {
+ package Io::Vivify;
+ no warnings 'once';
+ ::isa_ok(*FOO{IO}, 'IO');
+ ::is(<FOO>, "foo",
+ "stash has the right variable");
+ }
}
done_testing;
diff --git a/t/05-isa.t b/t/05-isa.t
index 3198fb1..0b41b72 100644
--- a/t/05-isa.t
+++ b/t/05-isa.t
@@ -15,7 +15,7 @@ use Package::Stash;
my $stash = Package::Stash->new('Foo');
my @ISA = ('Bar');
-@{$stash->get_package_symbol('@ISA')} = @ISA;
+@{$stash->get_or_add_package_symbol('@ISA')} = @ISA;
isa_ok('Foo', 'Bar');
done_testing;