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;
# 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);
+# add_method on anon stashes triggers rt.perl #1804 otherwise
+# fixed in perl commit v5.13.3-70-g0fe688f
+use constant BROKEN_GLOB_ASSIGNMENT => ($] < 5.013004);
=head1 SYNOPSIS
sub new {
my $class = shift;
my ($package) = @_;
- my $namespace;
- return bless {
- 'package' => $package,
- }, $class;
+
+ if (!defined($package) || (ref($package) && reftype($package) ne 'HASH')) {
+ confess "Package::Stash->new must be passed the name of the "
+ . "package to access";
+ }
+ elsif (ref($package) && reftype($package) eq 'HASH') {
+ confess "The PP implementation of Package::Stash does not support "
+ . "anonymous stashes before perl 5.14"
+ if BROKEN_GLOB_ASSIGNMENT;
+
+ return bless {
+ 'namespace' => $package,
+ }, $class;
+ }
+ elsif ($package =~ /\A[0-9A-Z_a-z]+(?:::[0-9A-Z_a-z]+)*\z/) {
+ return bless {
+ 'package' => $package,
+ }, $class;
+ }
+ else {
+ confess "$package is not a module name";
+ }
+
}
sub name {
confess "Can't call name as a class method"
unless blessed($_[0]);
+ confess "Can't get the name of an anonymous package"
+ unless defined($_[0]->{package});
return $_[0]->{package};
}
}
}
+sub _is_anon {
+ return !defined $_[0]->{package};
+}
+
{
my %SIGIL_MAP = (
'$' => 'SCALAR',
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;
}
}
}
else {
my $ref = reftype($value);
- return !defined($ref) || $ref eq 'SCALAR' || $ref eq 'REF' || $ref eq 'LVALUE';
+ return !defined($ref) || $ref eq 'SCALAR' || $ref eq 'REF' || $ref eq 'LVALUE' || $ref eq 'REGEXP' || $ref eq 'VSTRING';
}
}
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 $pkg = $self->name;
+ my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
if (@_ > 2) {
$self->_valid_for_type($initial_value, $type)
my $last_line_num = $opts{last_line_num} || ($first_line_num ||= 0);
# http://perldoc.perl.org/perldebguts.html#Debugger-Internals
- $DB::sub{$pkg . '::' . $name} = "$filename:$first_line_num-$last_line_num";
+ $DB::sub{$self->name . '::' . $name} = "$filename:$first_line_num-$last_line_num";
+ }
+ }
+
+ if (BROKEN_GLOB_ASSIGNMENT) {
+ if (@_ > 2) {
+ no strict 'refs';
+ *{ $self->name . '::' . $name } = ref $initial_value
+ ? $initial_value : \$initial_value;
+ }
+ else {
+ no strict 'refs';
+ *{ $self->name . '::' . $name };
}
}
+ else {
+ my $namespace = $self->namespace;
+ $namespace->{$name} ||= *{ Symbol::gensym() };
- no strict 'refs';
- no warnings 'redefine', 'misc', 'prototype';
- *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
+ if (@_ > 2) {
+ no warnings 'redefine';
+ *{ $namespace->{$name} } = ref $initial_value
+ ? $initial_value : \$initial_value;
+ }
+ }
}
sub remove_glob {
my ($self, $name) = @_;
- no strict 'refs';
- delete ${$self->name . '::'}{$name};
+ delete $self->namespace->{$name};
}
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;
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};
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;
}
else {
if ($type eq 'CODE') {
- no strict 'refs';
- return \&{ $self->name . '::' . $name };
+ if (BROKEN_GLOB_ASSIGNMENT || !$self->_is_anon) {
+ no strict 'refs';
+ return \&{ $self->name . '::' . $name };
+ }
+
+ # XXX we should really be able to support arbitrary anonymous
+ # stashes here... (not just via Package::Anon)
+ if (blessed($namespace) && $namespace->isa('Package::Anon')) {
+ # ->can will call gv_init for us, which inflates the glob
+ # don't know how to do this in general
+ $namespace->bless(\(my $foo))->can($name);
+ }
+ else {
+ confess "Don't know how to inflate a " . ref($entry_ref)
+ . " into a full coderef (perhaps you could use"
+ . " Package::Anon instead of a bare stash?)"
+ }
+
+ return *{ $namespace->{$name} }{CODE};
}
else {
return undef;
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
$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);
$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;
}
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 {
=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 -
projects / gitmo/Package-Stash.git / blobdiff