X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FPackage%2FStash%2FPP.pm;h=a8315640a7e48125f5885f5947183615930561fc;hb=f253ff9ea6aad9021b3a0d15449e8097d348402a;hp=d6ca34bfacaafa04f8890c0bbf389d0f1cb24c81;hpb=cdb543b5aa5181944c59414e1129702110a83fe1;p=gitmo%2FPackage-Stash.git diff --git a/lib/Package/Stash/PP.pm b/lib/Package/Stash/PP.pm index d6ca34b..a831564 100644 --- a/lib/Package/Stash/PP.pm +++ b/lib/Package/Stash/PP.pm @@ -3,12 +3,22 @@ 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); +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); +# 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 @@ -23,29 +33,63 @@ This is a backend for L implemented in pure perl, for those with sub new { my $class = shift; my ($package) = @_; - my $namespace; - { - no strict 'refs'; - # supposedly this caused a bug in earlier perls, but I can't reproduce - # it, so re-enabling the caching - $namespace = \%{$package . '::'}; + + 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; } - return bless { - 'package' => $package, - 'namespace' => $namespace, - }, $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 namespace { confess "Can't call namespace as a class method" unless blessed($_[0]); - return $_[0]->{namespace}; + + if (BROKEN_WEAK_STASH) { + no strict 'refs'; + return \%{$_[0]->name . '::'}; + } + else { + return $_[0]->{namespace} if defined $_[0]->{namespace}; + + { + no strict 'refs'; + $_[0]->{namespace} = \%{$_[0]->name . '::'}; + } + + weaken($_[0]->{namespace}); + + return $_[0]->{namespace}; + } +} + +sub _is_anon { + return !defined $_[0]->{package}; } { @@ -60,17 +104,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; } } @@ -83,18 +141,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) @@ -111,27 +165,42 @@ 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; + 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() }; + + 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; @@ -139,12 +208,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}; @@ -160,9 +230,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; @@ -207,8 +275,25 @@ sub get_symbol { } 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; @@ -224,9 +309,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 @@ -248,25 +331,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); @@ -277,7 +360,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; @@ -303,8 +386,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 { @@ -331,11 +420,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 -