X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FPackage%2FStash%2FPP.pm;h=f60ac4a3aa77bf0b0260a283a71730b38a1ada67;hb=50419d916de6240d6dd8ea2af69b628db0c287ba;hp=76129ed3803b3ba9fd537b4ff9ba89f35c713037;hpb=d173d3a338b6b69f9d84006f05fc50c95193919a;p=gitmo%2FPackage-Stash.git diff --git a/lib/Package/Stash/PP.pm b/lib/Package/Stash/PP.pm index 76129ed..f60ac4a 100644 --- a/lib/Package/Stash/PP.pm +++ b/lib/Package/Stash/PP.pm @@ -3,6 +3,7 @@ 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; @@ -12,6 +13,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); =head1 SYNOPSIS @@ -36,6 +40,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, @@ -82,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; } } @@ -112,11 +133,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 $pkg = $self->name; + my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable); if (@_ > 2) { $self->_valid_for_type($initial_value, $type) @@ -133,13 +150,14 @@ sub add_symbol { 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"; } } - no strict 'refs'; - no warnings 'redefine', 'misc', 'prototype'; - *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value; + my $namespace = $self->namespace; + my $gv = $namespace->{$name} || Symbol::gensym; + *$gv = ref $initial_value ? $initial_value : \$initial_value; + $namespace->{$name} = *$gv; } sub remove_glob { @@ -150,9 +168,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; @@ -160,12 +176,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}; @@ -181,9 +198,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; @@ -245,9 +260,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 @@ -269,25 +282,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); @@ -298,7 +311,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; @@ -324,8 +337,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 { @@ -352,11 +371,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 -