X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FPackage%2FStash%2FPP.pm;h=4996c392852b04c03b777fa84fc3f944bc7cbc6e;hb=d93368f69fbfbea0dcc645a0da00e13d7394eb94;hp=446642bcfc1390ed55001091effe6053bd3f626c;hpb=2905fb35f8d7e19e0b9422060689d71c72bb6f39;p=gitmo%2FPackage-Stash.git diff --git a/lib/Package/Stash/PP.pm b/lib/Package/Stash/PP.pm index 446642b..4996c39 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,59 @@ 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}; + } } { @@ -60,17 +100,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 +137,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 +161,41 @@ 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) { + *{ $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 +203,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 +225,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; @@ -196,13 +259,7 @@ sub get_symbol { } } else { - if ($type eq 'CODE') { - # this effectively "de-vivifies" the code slot. if we don't do - # this, referencing the coderef at the end of this function - # will cause perl to auto-vivify a stub coderef in the slot, - # which isn't what we want - $self->add_symbol($variable); - } + return undef; } } @@ -213,8 +270,19 @@ sub get_symbol { } else { if ($type eq 'CODE') { - 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 (!BROKEN_GLOB_ASSIGNMENT + && blessed($namespace) + && $namespace->isa('Package::Anon')) { + # ->can will call gv_init for us + $namespace->bless(\(my $foo))->can($name); + return *{ $namespace->{$name} }{CODE}; + } + else { + no strict 'refs'; + return \&{ $self->name . '::' . $name }; + } } else { return undef; @@ -230,9 +298,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 @@ -254,25 +320,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); @@ -283,7 +349,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; @@ -309,8 +375,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 { @@ -337,11 +409,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 - @@ -351,6 +418,12 @@ considered a feature in some cases (this is how L works, for instance), but should not be relied upon - use C directly if you want this behavior. +=item * Some minor memory leaks + +The pure perl implementation has a couple minor memory leaks (see the TODO +tests in t/20-leaks.t) that I'm having a hard time tracking down - these may be +core perl bugs, it's hard to tell. + =back Please report any bugs through RT: email @@ -402,6 +475,22 @@ Jesse Luehrs Mostly copied from code from L, by Stevan Little and the Moose Cabal. +=begin Pod::Coverage + +BROKEN_ISA_ASSIGNMENT +add_symbol +get_all_symbols +get_or_add_symbol +get_symbol +has_symbol +list_all_symbols +name +namespace +new +remove_glob + +=end Pod::Coverage + =cut 1;