X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FPackage%2FStash.pm;h=59e2853b36d045873c2838105515aebb9e6c99cb;hb=86cf2011e6d3db989f65c31979a00a1acf30220e;hp=d632c3797f4cf18fee6ff9b4f3e4637a05818014;hpb=640de3695dc6b9a77793ee3c1c03c5f062906295;p=gitmo%2FPackage-Stash.git diff --git a/lib/Package/Stash.pm b/lib/Package/Stash.pm index d632c37..59e2853 100644 --- a/lib/Package/Stash.pm +++ b/lib/Package/Stash.pm @@ -1,20 +1,98 @@ package Package::Stash; use strict; use warnings; +# ABSTRACT: routines for manipulating stashes -use Carp qw(confess); -use Scalar::Util qw(reftype); +our $IMPLEMENTATION; -=head1 NAME +BEGIN { + $IMPLEMENTATION = $ENV{PACKAGE_STASH_IMPLEMENTATION} + if exists $ENV{PACKAGE_STASH_IMPLEMENTATION}; -Package::Stash - routines for manipulating stashes + my $err; + if ($IMPLEMENTATION) { + if (!eval "require Package::Stash::$IMPLEMENTATION; 1") { + require Carp; + Carp::croak("Could not load Package::Stash::$IMPLEMENTATION: $@"); + } + } + else { + for my $impl ('XS', 'PP') { + if (eval "require Package::Stash::$impl; 1;") { + $IMPLEMENTATION = $impl; + last; + } + else { + $err .= $@; + } + } + } + + if (!$IMPLEMENTATION) { + require Carp; + Carp::croak("Could not find a suitable Package::Stash implementation: $err"); + } + + my $impl = "Package::Stash::$IMPLEMENTATION"; + my $from = $impl->new($impl); + my $to = $impl->new(__PACKAGE__); + my $methods = $from->get_all_symbols('CODE'); + for my $meth (keys %$methods) { + $to->add_symbol("&$meth" => $methods->{$meth}); + } +} + +use Package::DeprecationManager -deprecations => { + 'Package::Stash::add_package_symbol' => 0.14, + 'Package::Stash::remove_package_glob' => 0.14, + 'Package::Stash::has_package_symbol' => 0.14, + 'Package::Stash::get_package_symbol' => 0.14, + 'Package::Stash::get_or_add_package_symbol' => 0.14, + 'Package::Stash::remove_package_symbol' => 0.14, + 'Package::Stash::list_all_package_symbols' => 0.14, +}; + +sub add_package_symbol { + deprecated('add_package_symbol is deprecated, please use add_symbol'); + shift->add_symbol(@_); +} + +sub remove_package_glob { + deprecated('remove_package_glob is deprecated, please use remove_glob'); + shift->remove_glob(@_); +} + +sub has_package_symbol { + deprecated('has_package_symbol is deprecated, please use has_symbol'); + shift->has_symbol(@_); +} + +sub get_package_symbol { + deprecated('get_package_symbol is deprecated, please use get_symbol'); + shift->get_symbol(@_); +} + +sub get_or_add_package_symbol { + deprecated('get_or_add_package_symbol is deprecated, please use get_or_add_symbol'); + shift->get_or_add_symbol(@_); +} + +sub remove_package_symbol { + deprecated('remove_package_symbol is deprecated, please use remove_symbol'); + shift->remove_symbol(@_); +} + +sub list_all_package_symbols { + deprecated('list_all_package_symbols is deprecated, please use list_all_symbols'); + shift->list_all_symbols(@_); +} =head1 SYNOPSIS my $stash = Package::Stash->new('Foo'); - $stash->add_package_symbol('%foo', {bar => 1}); + $stash->add_symbol('%foo', {bar => 1}); # $Foo::foo{bar} == 1 - $stash->has_package_symbol('$foo') # false + $stash->has_symbol('$foo') # false my $namespace = $stash->namespace; *{ $namespace->{foo} }{HASH} # {bar => 1} @@ -27,348 +105,108 @@ simple API. NOTE: Most methods in this class require a variable specification that includes a sigil. If this sigil is absent, it is assumed to represent the IO slot. -=head1 METHODS +Due to limitations in the typeglob API available to perl code, and to typeglob +manipulation in perl being quite slow, this module provides two +implementations - one in pure perl, and one using XS. The XS implementation is +to be preferred for most usages; the pure perl one is provided for cases where +XS modules are not a possibility. The current implementation in use can be set +by setting C<$ENV{PACKAGE_STASH_IMPLEMENTATION}> or +C<$Package::Stash::IMPLEMENTATION> before loading Package::Stash (with the +environment variable taking precedence), otherwise, it will use the XS +implementation if possible, falling back to the pure perl one. -=cut - -=head2 new $package_name +=method new $package_name Creates a new C object, for the package given as the only argument. -=cut - -sub new { - my $class = shift; - my ($namespace) = @_; - return bless { 'package' => $namespace }, $class; -} - -=head2 name +=method name Returns the name of the package that this object represents. -=cut - -sub name { - return $_[0]->{package}; -} - -=head2 namespace +=method namespace Returns the raw stash itself. -=cut - -sub namespace { - # NOTE: - # because of issues with the Perl API - # to the typeglob in some versions, we - # need to just always grab a new - # reference to the hash here. Ideally - # we could just store a ref and it would - # Just Work, but oh well :\ - no strict 'refs'; - return \%{$_[0]->name . '::'}; -} - -{ - my %SIGIL_MAP = ( - '$' => 'SCALAR', - '@' => 'ARRAY', - '%' => 'HASH', - '&' => 'CODE', - '' => 'IO', - ); - - 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}); - } - else { - return ("${sigil}${variable}", '', $SIGIL_MAP{''}); - } - } -} - -=head2 add_package_symbol $variable $value $filename $firstlinenum $lastlinenum +=method add_symbol $variable $value %opts Adds a new package symbol, for the symbol given as C<$variable>, and optionally gives it an initial value of C<$value>. C<$variable> should be the name of variable including the sigil, so - Package::Stash->new('Foo')->add_package_symbol('%foo') + Package::Stash->new('Foo')->add_symbol('%foo') will create C<%Foo::foo>. -The optional $filename, $firstlinenum, and $lastlinenum arguments can be used -to indicate where the symbol should be regarded as having been defined. +Valid options (all optional) are C, C, and +C. + +C<$opts{filename}>, C<$opts{first_line_num}>, and C<$opts{last_line_num}> can +be used to indicate where the symbol should be regarded as having been defined. Currently these values are only used if the symbol is a subroutine ('C<&>' -sigil) and only if C<$^P & 0x10> is true. In which case the special -C<%DB::sub> hash is updated to record the values of $filename, $firstlinenum, -and $lastlinenum for the subroutine. +sigil) and only if C<$^P & 0x10> is true, in which case the special C<%DB::sub> +hash is updated to record the values of C, C, and +C for the subroutine. If these are not passed, their values are +inferred (as much as possible) from C information. This is especially useful for debuggers and profilers, which use C<%DB::sub> to determine where the source code for a subroutine can be found. See L for more information about C<%DB::sub>. -=cut - -sub _valid_for_type { - my $self = shift; - my ($value, $type) = @_; - if ($type eq 'HASH' || $type eq 'ARRAY' - || $type eq 'IO' || $type eq 'CODE') { - return reftype($value) eq $type; - } - else { - my $ref = reftype($value); - return !defined($ref) || $ref eq 'SCALAR' || $ref eq 'REF' || $ref eq 'LVALUE'; - } -} - -sub add_package_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; - - if (@_ > 2) { - $self->_valid_for_type($initial_value, $type) - || confess "$initial_value is not of type $type"; - - # cheap fail-fast check for PERLDBf_SUBLINE and '&' - if ($^P and $^P & 0x10 && $sigil eq '&') { - my $filename = $opts{filename}; - my $first_line_num = $opts{first_line_num}; - - (undef, $filename, $first_line_num) = caller - if not defined $filename; - - 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"; - } - } - - no strict 'refs'; - no warnings 'redefine', 'misc', 'prototype'; - *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value; -} - -=head2 remove_package_glob $name +=method remove_glob $name Removes all package variables with the given name, regardless of sigil. -=cut - -sub remove_package_glob { - my ($self, $name) = @_; - no strict 'refs'; - delete ${$self->name . '::'}{$name}; -} - -# ... these functions deal with stuff on the namespace level - -=head2 has_package_symbol $variable +=method has_symbol $variable Returns whether or not the given package variable (including sigil) exists. -=cut - -sub has_package_symbol { - my ($self, $variable) = @_; - - my ($name, $sigil, $type) = ref $variable eq 'HASH' - ? @{$variable}{qw[name sigil type]} - : $self->_deconstruct_variable_name($variable); - - my $namespace = $self->namespace; - - return unless exists $namespace->{$name}; - - my $entry_ref = \$namespace->{$name}; - if (reftype($entry_ref) eq 'GLOB') { - if ( $type eq 'SCALAR' ) { - return defined ${ *{$entry_ref}{SCALAR} }; - } - else { - return defined *{$entry_ref}{$type}; - } - } - else { - # a symbol table entry can be -1 (stub), string (stub with prototype), - # or reference (constant) - return $type eq 'CODE'; - } -} - -=head2 get_package_symbol $variable +=method get_symbol $variable Returns the value of the given package variable (including sigil). -=cut - -sub get_package_symbol { - my ($self, $variable) = @_; - - my ($name, $sigil, $type) = ref $variable eq 'HASH' - ? @{$variable}{qw[name sigil type]} - : $self->_deconstruct_variable_name($variable); - - my $namespace = $self->namespace; - - if (!exists $namespace->{$name}) { - # assigning to the result of this function like - # @{$stash->get_package_symbol('@ISA')} = @new_ISA - # makes the result not visible until the variable is explicitly - # accessed... in the case of @ISA, this might never happen - # for instance, assigning like that and then calling $obj->isa - # will fail. see t/005-isa.t - if ($type eq 'ARRAY' && $name ne 'ISA') { - $self->add_package_symbol($variable, []); - } - elsif ($type eq 'HASH') { - $self->add_package_symbol($variable, {}); - } - else { - # FIXME - $self->add_package_symbol($variable) - } - } - - my $entry_ref = \$namespace->{$name}; +=method get_or_add_symbol $variable - if (ref($entry_ref) eq 'GLOB') { - return *{$entry_ref}{$type}; - } - else { - if ($type eq 'CODE') { - no strict 'refs'; - return \&{ $self->name . '::' . $name }; - } - else { - return undef; - } - } -} +Like C, except that it will return an empty hashref or +arrayref if the variable doesn't exist. -=head2 remove_package_symbol $variable +=method remove_symbol $variable Removes the package variable described by C<$variable> (which includes the sigil); other variables with the same name but different sigils will be untouched. -=cut +=method list_all_symbols $type_filter -sub remove_package_symbol { - my ($self, $variable) = @_; - - my ($name, $sigil, $type) = ref $variable eq 'HASH' - ? @{$variable}{qw[name sigil type]} - : $self->_deconstruct_variable_name($variable); - - # FIXME: - # no doubt this is grossly inefficient and - # could be done much easier and faster in XS - - my ($scalar_desc, $array_desc, $hash_desc, $code_desc, $io_desc) = ( - { sigil => '$', type => 'SCALAR', name => $name }, - { sigil => '@', type => 'ARRAY', name => $name }, - { sigil => '%', type => 'HASH', name => $name }, - { sigil => '&', type => 'CODE', name => $name }, - { sigil => '', type => 'IO', name => $name }, - ); - - my ($scalar, $array, $hash, $code, $io); - if ($type eq 'SCALAR') { - $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc); - $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc); - $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc); - $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc); - } - elsif ($type eq 'ARRAY') { - $scalar = $self->get_package_symbol($scalar_desc); - $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc); - $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc); - $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc); - } - elsif ($type eq 'HASH') { - $scalar = $self->get_package_symbol($scalar_desc); - $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc); - $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc); - $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc); - } - elsif ($type eq 'CODE') { - $scalar = $self->get_package_symbol($scalar_desc); - $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc); - $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc); - $io = $self->get_package_symbol($io_desc) if $self->has_package_symbol($io_desc); - } - elsif ($type eq 'IO') { - $scalar = $self->get_package_symbol($scalar_desc); - $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc); - $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc); - $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc); - } - else { - confess "This should never ever ever happen"; - } +Returns a list of package variable names in the package, without sigils. If a +C is passed, it is used to select package variables of a given +type, where valid types are the slots of a typeglob ('SCALAR', 'CODE', 'HASH', +etc). Note that if the package contained any C blocks, perl will leave +an empty typeglob in the C slot, so this will show up if no filter is +used (and similarly for C, C, etc). - $self->remove_package_glob($name); +=method get_all_symbols $type_filter - $self->add_package_symbol($scalar_desc => $scalar); - $self->add_package_symbol($array_desc => $array) if defined $array; - $self->add_package_symbol($hash_desc => $hash) if defined $hash; - $self->add_package_symbol($code_desc => $code) if defined $code; - $self->add_package_symbol($io_desc => $io) if defined $io; -} +Returns a hashref, keyed by the variable names in the package. If +C<$type_filter> is passed, the hash will contain every variable of that type in +the package as values, otherwise, it will contain the typeglobs corresponding +to the variable names (basically, a clone of the stash). -=head2 list_all_package_symbols $type_filter +=head1 BUGS / CAVEATS -Returns a list of package variable names in the package, without sigils. If a -C is passed, it is used to select package variables of a given -type, where valid types are the slots of a typeglob ('SCALAR', 'CODE', 'HASH', -etc). +=over 4 -=cut +=item * Prior to perl 5.10, scalar slots are only considered to exist if they are defined -sub list_all_package_symbols { - my ($self, $type_filter) = @_; - - my $namespace = $self->namespace; - return keys %{$namespace} unless defined $type_filter; - - # NOTE: - # or we can filter based on - # type (SCALAR|ARRAY|HASH|CODE) - if ($type_filter eq 'CODE') { - return grep { - (ref($namespace->{$_}) - ? (ref($namespace->{$_}) eq 'SCALAR') - : (ref(\$namespace->{$_}) eq 'GLOB' - && defined(*{$namespace->{$_}}{CODE}))); - } keys %{$namespace}; - } else { - return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace}; - } -} +This is due to a shortcoming within perl itself. See +L point 7 for more information. + +=item * GLOB and FORMAT variables are not (yet) accessible through this module. -=head1 BUGS +=item * Also, see the BUGS section for the specific backends (L and L) -No known bugs. +=back Please report any bugs through RT: email C, or browse to @@ -376,8 +214,13 @@ L. =head1 SEE ALSO -L - this module is a factoring out of code that used to -live here +=over 4 + +=item * L + +This module is a factoring out of code that used to live here + +=back =head1 SUPPORT @@ -409,17 +252,22 @@ L =head1 AUTHOR - Jesse Luehrs +Jesse Luehrs -Mostly copied from code from L, by Stevan Little and the -Moose Cabal. +Based on code from L, by Stevan Little and the Moose +Cabal. -=head1 COPYRIGHT AND LICENSE +=begin Pod::Coverage -This software is copyright (c) 2010 by Jesse Luehrs. +add_package_symbol +remove_package_glob +has_package_symbol +get_package_symbol +get_or_add_package_symbol +remove_package_symbol +list_all_package_symbols -This is free software; you can redistribute it and/or modify it under -the same terms as perl itself. +=end Pod::Coverage =cut