X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FPackage%2FStash%2FPP.pm;h=b3a8a52c5584c142993f8dbba97a5d60b3c0b35a;hb=65c14002306f89a5a3d5255e2c5ee66851f65398;hp=653eeafb9a23218a1b5a8ff11c4a902b8d260994;hpb=eb53b1bd771d2bed902655654014680ea64cf8d4;p=gitmo%2FPackage-Stash.git diff --git a/lib/Package/Stash/PP.pm b/lib/Package/Stash/PP.pm index 653eeaf..b3a8a52 100644 --- a/lib/Package/Stash/PP.pm +++ b/lib/Package/Stash/PP.pm @@ -3,12 +3,19 @@ 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; # before 5.12, assigning to the ISA glob would make it lose its magical ->isa # powers 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); =head1 SYNOPSIS @@ -23,7 +30,20 @@ This is a backend for L implemented in pure perl, for those with sub new { my $class = shift; my ($package) = @_; - my $namespace; + + if (!defined($package) || (ref($package) && ref($package) ne 'HASH')) { + confess "Package::Stash->new must be passed the name of the " + . "package to access"; + } + elsif (ref($package) eq 'HASH') { + confess "The pure perl implementation of Package::Stash doesn't " + . "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, }, $class; @@ -38,18 +58,23 @@ sub name { sub namespace { confess "Can't call namespace as a class method" unless blessed($_[0]); - return $_[0]->{namespace} if defined $_[0]->{namespace}; - { + if (BROKEN_WEAK_STASH) { no strict 'refs'; - # supposedly this caused a bug in earlier perls, but I can't reproduce - # it, so re-enabling the caching - $_[0]->{namespace} = \%{$_[0]->name . '::'}; + return \%{$_[0]->name . '::'}; } + else { + return $_[0]->{namespace} if defined $_[0]->{namespace}; - weaken($_[0]->{namespace}); + { + no strict 'refs'; + $_[0]->{namespace} = \%{$_[0]->name . '::'}; + } + + weaken($_[0]->{namespace}); - return $_[0]->{namespace}; + return $_[0]->{namespace}; + } } { @@ -64,17 +89,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; } } @@ -87,16 +126,14 @@ sub _valid_for_type { } 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 ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable); my $pkg = $self->name; @@ -126,16 +163,13 @@ sub add_symbol { 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; @@ -143,12 +177,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}; @@ -164,9 +199,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; @@ -228,9 +261,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 @@ -252,25 +283,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); @@ -281,7 +312,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; @@ -307,8 +338,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 { @@ -335,11 +372,6 @@ sub get_all_symbols { =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 point 7 for more information. - =item * remove_symbol also replaces the associated typeglob This can cause unexpected behavior when doing manipulation at compile time -