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=60c486adb193422908a4742828727baeb8fcdc66;hpb=36cbfbad272906e832c887c1e07a22e21bd3b894;p=gitmo%2FPackage-Stash.git diff --git a/lib/Package/Stash/PP.pm b/lib/Package/Stash/PP.pm index 60c486a..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 @@ -26,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; @@ -72,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; } } @@ -95,18 +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 $pkg = $self->name; + my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable); if (@_ > 2) { $self->_valid_for_type($initial_value, $type) @@ -123,27 +150,25 @@ 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 { 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; @@ -151,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}; @@ -172,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; @@ -236,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 @@ -260,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); @@ -289,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; @@ -315,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 { @@ -343,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 -