Commit 69fe2eab authored by Alessandro Ghedini's avatar Alessandro Ghedini

Imported Upstream version 0.32

parent d2f36e20
Revision history for Package-Stash
0.32 2011-09-05
- bring the behavior of has_symbol for nonexistant scalars into line with
the xs version
- invalid package names (for instance, Foo:Bar) are not allowed
- invalid stash entry names (anything containing ::) are not allowed
0.31 2011-08-08
- fix ->add_symbol('$foo', qr/sdlfk/) on 5.12+
- fix ->add_symbol('$foo', \v1.2.3) on 5.10+
......
......@@ -14,8 +14,8 @@ lib/Package/Stash/Conflicts.pm
lib/Package/Stash/PP.pm
t/00-compile.t
t/addsub.t
t/author-20-leaks.t
t/author-21-leaks-debug.t
t/author-leaks-debug.t
t/author-leaks.t
t/basic.t
t/compile-time.t
t/edge-cases.t
......@@ -30,6 +30,7 @@ t/io.t
t/isa.t
t/lib/CompileTime.pm
t/lib/Package/Stash.pm
t/paamayim_nekdotayim.t
t/release-eol.t
t/release-no-tabs.t
t/release-pod-coverage.t
......
......@@ -27,7 +27,7 @@
},
"runtime" : {
"recommends" : {
"Package::Stash::XS" : "0.22"
"Package::Stash::XS" : "0.24"
},
"requires" : {
"Dist::CheckConflicts" : "0.02",
......@@ -52,7 +52,7 @@
"web" : "http://github.com/doy/package-stash"
}
},
"version" : "0.31",
"version" : "0.32",
"x_Dist_Zilla" : {
"plugins" : [
{
......
......@@ -17,7 +17,7 @@ meta-spec:
version: 1.4
name: Package-Stash
recommends:
Package::Stash::XS: 0.22
Package::Stash::XS: 0.24
requires:
Dist::CheckConflicts: 0.02
Package::DeprecationManager: 0
......@@ -25,7 +25,7 @@ requires:
perl: 5.8.1
resources:
repository: git://github.com/doy/package-stash.git
version: 0.31
version: 0.32
x_Dist_Zilla:
plugins:
-
......
......@@ -29,7 +29,7 @@ my %WriteMakefileArgs = (
'Package::DeprecationManager' => '0',
'Scalar::Util' => '0'
},
'VERSION' => '0.31',
'VERSION' => '0.32',
'test' => {
'TESTS' => 't/*.t t/impl-selection/*.t'
}
......@@ -52,7 +52,7 @@ unless ( eval { ExtUtils::MakeMaker->VERSION(6.56) } ) {
delete $WriteMakefileArgs{CONFIGURE_REQUIRES}
unless eval { ExtUtils::MakeMaker->VERSION(6.52) };
$WriteMakefileArgs{PREREQ_PM}{'Package::Stash::XS'} = 0.22
$WriteMakefileArgs{PREREQ_PM}{'Package::Stash::XS'} = 0.24
if can_cc();
WriteMakefile(%WriteMakefileArgs);
......
This archive contains the distribution Package-Stash,
version 0.31:
version 0.32:
routines for manipulating stashes
......
......@@ -18,7 +18,7 @@ Package::DeprecationManager = 0
Scalar::Util = 0
[Prereqs / RuntimeRecommends]
Package::Stash::XS = 0.22
Package::Stash::XS = 0.24
[Prereqs / TestRequires]
Test::Fatal = 0
......
package Package::Stash;
BEGIN {
$Package::Stash::VERSION = '0.31';
$Package::Stash::VERSION = '0.32';
}
use strict;
use warnings;
......@@ -102,7 +102,7 @@ Package::Stash - routines for manipulating stashes
=head1 VERSION
version 0.31
version 0.32
=head1 SYNOPSIS
......@@ -216,6 +216,11 @@ to the variable names (basically, a clone of the stash).
=over 4
=item * Prior to perl 5.10, scalar slots are only considered to exist if they are defined
This is due to a shortcoming within perl itself. See
L<perlref/Making References> point 7 for more information.
=item * GLOB and FORMAT variables are not (yet) accessible through this module.
=item * Also, see the BUGS section for the specific backends (L<Package::Stash::XS> and L<Package::Stash::PP>)
......
package Package::Stash::PP;
BEGIN {
$Package::Stash::PP::VERSION = '0.31';
$Package::Stash::PP::VERSION = '0.32';
}
use strict;
use warnings;
# ABSTRACT: pure perl implementation of the Package::Stash API
use B;
use Carp qw(confess);
use Scalar::Util qw(blessed reftype weaken);
use Symbol;
......@@ -15,6 +16,9 @@ use constant BROKEN_ISA_ASSIGNMENT => ($] < 5.012);
# before 5.10, stashes don't ever seem to drop to a refcount of zero, so
# weakening them isn't helpful
use constant BROKEN_WEAK_STASH => ($] < 5.010);
# before 5.10, the scalar slot was always treated as existing if the
# glob existed
use constant BROKEN_SCALAR_INITIALIZATION => ($] < 5.010);
sub new {
......@@ -30,6 +34,9 @@ sub new {
. "currently support anonymous stashes. You should install "
. "Package::Stash::XS";
}
elsif ($package !~ /\A[0-9A-Z_a-z]+(?:::[0-9A-Z_a-z]+)*\z/) {
confess "$package is not a module name";
}
return bless {
'package' => $package,
......@@ -76,17 +83,31 @@ sub namespace {
sub _deconstruct_variable_name {
my ($self, $variable) = @_;
(defined $variable && length $variable)
|| confess "You must pass a variable name";
my $sigil = substr($variable, 0, 1, '');
if (exists $SIGIL_MAP{$sigil}) {
return ($variable, $sigil, $SIGIL_MAP{$sigil});
my @ret;
if (ref($variable) eq 'HASH') {
@ret = @{$variable}{qw[name sigil type]};
}
else {
return ("${sigil}${variable}", '', $SIGIL_MAP{''});
(defined $variable && length $variable)
|| confess "You must pass a variable name";
my $sigil = substr($variable, 0, 1, '');
if (exists $SIGIL_MAP{$sigil}) {
@ret = ($variable, $sigil, $SIGIL_MAP{$sigil});
}
else {
@ret = ("${sigil}${variable}", '', $SIGIL_MAP{''});
}
}
# XXX in pure perl, this will access things in inner packages,
# in xs, this will segfault - probably look more into this at
# some point
($ret[0] !~ /::/)
|| confess "Variable names may not contain ::";
return @ret;
}
}
......@@ -106,9 +127,7 @@ sub _valid_for_type {
sub add_symbol {
my ($self, $variable, $initial_value, %opts) = @_;
my ($name, $sigil, $type) = ref $variable eq 'HASH'
? @{$variable}{qw[name sigil type]}
: $self->_deconstruct_variable_name($variable);
my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
my $pkg = $self->name;
......@@ -144,9 +163,7 @@ sub remove_glob {
sub has_symbol {
my ($self, $variable) = @_;
my ($name, $sigil, $type) = ref $variable eq 'HASH'
? @{$variable}{qw[name sigil type]}
: $self->_deconstruct_variable_name($variable);
my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
my $namespace = $self->namespace;
......@@ -154,12 +171,13 @@ sub has_symbol {
my $entry_ref = \$namespace->{$name};
if (reftype($entry_ref) eq 'GLOB') {
# XXX: assigning to any typeglob slot also initializes the SCALAR slot,
# and saying that an undef scalar variable doesn't exist is probably
# vaguely less surprising than a scalar variable popping into existence
# without anyone defining it
if ($type eq 'SCALAR') {
return defined ${ *{$entry_ref}{$type} };
if (BROKEN_SCALAR_INITIALIZATION) {
return defined ${ *{$entry_ref}{$type} };
}
else {
return B::svref_2object($entry_ref)->SV->isa('B::SV');
}
}
else {
return defined *{$entry_ref}{$type};
......@@ -175,9 +193,7 @@ sub has_symbol {
sub get_symbol {
my ($self, $variable, %opts) = @_;
my ($name, $sigil, $type) = ref $variable eq 'HASH'
? @{$variable}{qw[name sigil type]}
: $self->_deconstruct_variable_name($variable);
my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
my $namespace = $self->namespace;
......@@ -239,9 +255,7 @@ sub get_or_add_symbol {
sub remove_symbol {
my ($self, $variable) = @_;
my ($name, $sigil, $type) = ref $variable eq 'HASH'
? @{$variable}{qw[name sigil type]}
: $self->_deconstruct_variable_name($variable);
my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
# FIXME:
# no doubt this is grossly inefficient and
......@@ -263,25 +277,25 @@ sub remove_symbol {
$io = $self->get_symbol($io_desc) if $self->has_symbol($io_desc);
}
elsif ($type eq 'ARRAY') {
$scalar = $self->get_symbol($scalar_desc);
$scalar = $self->get_symbol($scalar_desc) if $self->has_symbol($scalar_desc) || BROKEN_SCALAR_INITIALIZATION;
$hash = $self->get_symbol($hash_desc) if $self->has_symbol($hash_desc);
$code = $self->get_symbol($code_desc) if $self->has_symbol($code_desc);
$io = $self->get_symbol($io_desc) if $self->has_symbol($io_desc);
}
elsif ($type eq 'HASH') {
$scalar = $self->get_symbol($scalar_desc);
$scalar = $self->get_symbol($scalar_desc) if $self->has_symbol($scalar_desc) || BROKEN_SCALAR_INITIALIZATION;
$array = $self->get_symbol($array_desc) if $self->has_symbol($array_desc);
$code = $self->get_symbol($code_desc) if $self->has_symbol($code_desc);
$io = $self->get_symbol($io_desc) if $self->has_symbol($io_desc);
}
elsif ($type eq 'CODE') {
$scalar = $self->get_symbol($scalar_desc);
$scalar = $self->get_symbol($scalar_desc) if $self->has_symbol($scalar_desc) || BROKEN_SCALAR_INITIALIZATION;
$array = $self->get_symbol($array_desc) if $self->has_symbol($array_desc);
$hash = $self->get_symbol($hash_desc) if $self->has_symbol($hash_desc);
$io = $self->get_symbol($io_desc) if $self->has_symbol($io_desc);
}
elsif ($type eq 'IO') {
$scalar = $self->get_symbol($scalar_desc);
$scalar = $self->get_symbol($scalar_desc) if $self->has_symbol($scalar_desc) || BROKEN_SCALAR_INITIALIZATION;
$array = $self->get_symbol($array_desc) if $self->has_symbol($array_desc);
$hash = $self->get_symbol($hash_desc) if $self->has_symbol($hash_desc);
$code = $self->get_symbol($code_desc) if $self->has_symbol($code_desc);
......@@ -292,7 +306,7 @@ sub remove_symbol {
$self->remove_glob($name);
$self->add_symbol($scalar_desc => $scalar);
$self->add_symbol($scalar_desc => $scalar) if defined $scalar;
$self->add_symbol($array_desc => $array) if defined $array;
$self->add_symbol($hash_desc => $hash) if defined $hash;
$self->add_symbol($code_desc => $code) if defined $code;
......@@ -318,8 +332,14 @@ sub list_all_symbols {
}
elsif ($type_filter eq 'SCALAR') {
return grep {
ref(\$namespace->{$_}) eq 'GLOB'
&& defined(${*{$namespace->{$_}}{'SCALAR'}})
BROKEN_SCALAR_INITIALIZATION
? (ref(\$namespace->{$_}) eq 'GLOB'
&& defined(${*{$namespace->{$_}}{'SCALAR'}}))
: (do {
my $entry = \$namespace->{$_};
ref($entry) eq 'GLOB'
&& B::svref_2object($entry)->SV->isa('B::SV')
})
} keys %{$namespace};
}
else {
......@@ -354,7 +374,7 @@ Package::Stash::PP - pure perl implementation of the Package::Stash API
=head1 VERSION
version 0.31
version 0.32
=head1 SYNOPSIS
......@@ -368,11 +388,6 @@ This is a backend for L<Package::Stash> implemented in pure perl, for those with
=over 4
=item * Scalar slots are only considered to exist if they are defined
This is due to a shortcoming within perl itself. See
L<perlref/Making References> point 7 for more information.
=item * remove_symbol also replaces the associated typeglob
This can cause unexpected behavior when doing manipulation at compile time -
......
......@@ -69,16 +69,24 @@ use Symbol;
{
my $foo = Package::Stash->new('Foo');
{ local $TODO = $Package::Stash::IMPLEMENTATION eq 'PP'
? "the pure perl implementation leaks here somehow"
: undef;
no_leaks_ok {
$foo->add_symbol('$scalar_init' => 1);
} "add_symbol scalar doesn't leak";
no_leaks_ok {
$foo->add_symbol('@array_init' => []);
} "add_symbol array doesn't leak";
no_leaks_ok {
$foo->add_symbol('%hash_init' => {});
} "add_symbol hash doesn't leak";
no_leaks_ok {
$foo->add_symbol('&code_init' => sub { "foo" });
} "add_symbol code doesn't leak";
{ local $TODO = $Package::Stash::IMPLEMENTATION eq 'PP'
? "the pure perl implementation leaks here somehow"
: undef;
no_leaks_ok {
$foo->add_symbol('io_init' => Symbol::geniosym);
} "add_symbol doesn't leak";
} "add_symbol io doesn't leak";
}
is(exception {
is(Foo->code_init, 'foo', "sub installed correctly")
......@@ -137,8 +145,8 @@ use Symbol;
@{$foo->get_or_add_symbol('@ISA')} = @super;
$foo->get_or_add_symbol('$glob');
} "get_or_add_symbol doesn't leak";
{ local $TODO = ($] < 5.010 || $Package::Stash::IMPLEMENTATION eq 'PP')
? "undef scalars aren't visible on 5.8, or from pure perl at all"
{ local $TODO = $] < 5.010
? "undef scalars aren't visible on 5.8"
: undef;
ok($foo->has_symbol('$glob'));
}
......
......@@ -67,16 +67,24 @@ use Symbol;
{
my $foo = Package::Stash->new('Foo');
{ local $TODO = $Package::Stash::IMPLEMENTATION eq 'PP'
? "the pure perl implementation leaks here somehow"
: undef;
no_leaks_ok {
$foo->add_symbol('$scalar_init' => 1);
} "add_symbol scalar doesn't leak";
no_leaks_ok {
$foo->add_symbol('@array_init' => []);
} "add_symbol array doesn't leak";
no_leaks_ok {
$foo->add_symbol('%hash_init' => {});
} "add_symbol hash doesn't leak";
no_leaks_ok {
$foo->add_symbol('&code_init' => sub { "foo" });
} "add_symbol code doesn't leak";
{ local $TODO = $Package::Stash::IMPLEMENTATION eq 'PP'
? "the pure perl implementation leaks here somehow"
: undef;
no_leaks_ok {
$foo->add_symbol('io_init' => Symbol::geniosym);
} "add_symbol doesn't leak";
} "add_symbol io doesn't leak";
}
is(exception {
is(Foo->code_init, 'foo', "sub installed correctly")
......@@ -135,8 +143,8 @@ use Symbol;
@{$foo->get_or_add_symbol('@ISA')} = @super;
$foo->get_or_add_symbol('$glob');
} "get_or_add_symbol doesn't leak";
{ local $TODO = ($] < 5.010 || $Package::Stash::IMPLEMENTATION eq 'PP')
? "undef scalars aren't visible on 5.8, or from pure perl at all"
{ local $TODO = $] < 5.010
? "undef scalars aren't visible on 5.8"
: undef;
ok($foo->has_symbol('$glob'));
}
......
......@@ -391,8 +391,8 @@ like(exception {
[qw(BEGIN bar baz foo quuuux quuux quux)],
"list_all_symbols",
);
{ local $TODO = ($] < 5.010 || $Package::Stash::IMPLEMENTATION eq 'PP')
? "undef scalars aren't visible on 5.8, or from pure perl at all"
{ local $TODO = $] < 5.010
? "undef scalars aren't visible on 5.8"
: undef;
is_deeply(
[sort $quuux->list_all_symbols('SCALAR')],
......@@ -417,4 +417,24 @@ like(exception {
);
}
for my $package ('Foo:Bar', 'Foo/Bar', 'Foo Bar', 'Foo:::Bar', '') {
like(
exception { Package::Stash->new($package) },
qr/^$package is not a module name/,
"$package is not a module name"
);
}
like(
exception { Package::Stash->new([]) },
qr/^Package::Stash->new must be passed the name of the package to access/,
"module name must be a string"
);
like(
exception { Package::Stash->new(undef) },
qr/^Package::Stash->new must be passed the name of the package to access/,
"module name must be a string"
);
done_testing;
......@@ -26,8 +26,8 @@ use Package::Stash;
}
my $stash = Package::Stash->new('Foo');
{ local $TODO = ($] < 5.010 || $Package::Stash::IMPLEMENTATION eq 'PP')
? "undef scalars aren't visible on 5.8, or from pure perl at all"
{ local $TODO = $] < 5.010
? "undef scalars aren't visible on 5.8"
: undef;
ok($stash->has_symbol('$SCALAR'), '$SCALAR');
}
......
......@@ -395,8 +395,8 @@ like(exception {
[qw(BEGIN bar baz foo quuuux quuux quux)],
"list_all_symbols",
);
{ local $TODO = ($] < 5.010 || $Package::Stash::IMPLEMENTATION eq 'PP')
? "undef scalars aren't visible on 5.8, or from pure perl at all"
{ local $TODO = $] < 5.010
? "undef scalars aren't visible on 5.8"
: undef;
is_deeply(
[sort $quuux->list_all_symbols('SCALAR')],
......
......@@ -396,8 +396,8 @@ like(exception {
[qw(BEGIN bar baz foo quuuux quuux quux)],
"list_all_symbols",
);
{ local $TODO = ($] < 5.010 || $Package::Stash::IMPLEMENTATION eq 'PP')
? "undef scalars aren't visible on 5.8, or from pure perl at all"
{ local $TODO = $] < 5.010
? "undef scalars aren't visible on 5.8"
: undef;
is_deeply(
[sort $quuux->list_all_symbols('SCALAR')],
......
#!/usr/bin/env perl
use strict;
use warnings;
use lib 't/lib';
use Test::More;
use Test::Fatal;
use Package::Stash;
my $stash = Package::Stash->new('Foo');
# this segfaulted on the xs version
like(
exception { $stash->add_symbol('@bar::baz') },
qr/^Variable names may not contain ::/,
"can't add symbol with ::"
);
like(
exception { $stash->get_symbol('@bar::baz') },
qr/^Variable names may not contain ::/,
"can't add symbol with ::"
);
like(
exception { $stash->get_or_add_symbol('@bar::baz') },
qr/^Variable names may not contain ::/,
"can't add symbol with ::"
);
done_testing;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment