From: Jesse Luehrs Date: Tue, 16 Nov 2010 04:48:50 +0000 (-0600) Subject: initial quite broken implementation of backend switching X-Git-Tag: 0.15~6 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e4afde02c9d7b7c2d1c031d18df418a166c0415f;p=gitmo%2FPackage-Stash.git initial quite broken implementation of backend switching --- diff --git a/dist.ini b/dist.ini index 8b69822..2ffa380 100644 --- a/dist.ini +++ b/dist.ini @@ -9,8 +9,14 @@ dist = Package-Stash awesome = =inc::MMPackageStash [Prereqs] +perl = 5.8.3 +Package::DeprecationManager = 0 Scalar::Util = 0 [Prereqs / TestRequires] Test::Fatal = 0 Test::More = 0.88 +Test::Requires = 0 + +[Prereqs / TestRecommends] +Test::LeakTrace = 0 diff --git a/lib/Package/Stash.pm b/lib/Package/Stash.pm new file mode 100644 index 0000000..b00630f --- /dev/null +++ b/lib/Package/Stash.pm @@ -0,0 +1,264 @@ +package Package::Stash; +use strict; +use warnings; +# ABSTRACT: routines for manipulating stashes + +our $IMPLEMENTATION; + +BEGIN { + #warn "loading Package::Stash"; + $IMPLEMENTATION = $ENV{PACKAGE_STASH_IMPLEMENTATION} + if exists $ENV{PACKAGE_STASH_IMPLEMENTATION}; + #warn "found $IMPLEMENTATION" if $IMPLEMENTATION; + + if (!$IMPLEMENTATION) { + #warn "detecting..."; + for my $impl ('XS', 'PP') { + if (eval "require Package::Stash::$impl; 1;") { + #warn "found $impl"; + $IMPLEMENTATION = $impl; + last; + } + } + } + + if (!$IMPLEMENTATION) { + require Carp; + Carp::croak("Could not find a suitable Package::Stash implementation"); + } + + 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) { + #warn "installing $meth"; + $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_symbol('%foo', {bar => 1}); + # $Foo::foo{bar} == 1 + $stash->has_symbol('$foo') # false + my $namespace = $stash->namespace; + *{ $namespace->{foo} }{HASH} # {bar => 1} + +=head1 DESCRIPTION + +Manipulating stashes (Perl's symbol tables) is occasionally necessary, but +incredibly messy, and easy to get wrong. This module hides all of that behind a +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. + +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. + +=method new $package_name + +Creates a new C object, for the package given as the only +argument. + +=method name + +Returns the name of the package that this object represents. + +=method namespace + +Returns the raw stash itself. + +=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_symbol('%foo') + +will create C<%Foo::foo>. + +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 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>. + +=method remove_glob $name + +Removes all package variables with the given name, regardless of sigil. + +=method has_symbol $variable + +Returns whether or not the given package variable (including sigil) exists. + +=method get_symbol $variable + +Returns the value of the given package variable (including sigil). + +=method get_or_add_symbol $variable + +Like C, except that it will return an empty hashref or +arrayref if the variable doesn't exist. + +=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. + +=method list_all_symbols $type_filter + +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). + +=method get_all_symbols $type_filter + +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). + +=head1 BUGS / CAVEATS + +=over 4 + +=item * GLOB and FORMAT variables are not (yet) accessible through this module. + +=item * Also, see the BUGS section for the specific backends (L and L) + +=back + +Please report any bugs through RT: email +C, or browse to +L. + +=head1 SEE ALSO + +=over 4 + +=item * L + +This module is a factoring out of code that used to live here + +=back + +=head1 SUPPORT + +You can find this documentation for this module with the perldoc command. + + perldoc Package::Stash + +You can also look for information at: + +=over 4 + +=item * AnnoCPAN: Annotated CPAN documentation + +L + +=item * CPAN Ratings + +L + +=item * RT: CPAN's request tracker + +L + +=item * Search CPAN + +L + +=back + +=head1 AUTHOR + +Jesse Luehrs + +Based on code from L, by Stevan Little and the Moose +Cabal. + +=begin Pod::Coverage + +add_package_symbol +remove_package_glob +has_package_symbol +get_package_symbol +get_or_add_package_symbol +remove_package_symbol +list_all_package_symbols + +=end Pod::Coverage + +=cut + +1; diff --git a/t/90-impl-selection.t b/t/90-impl-selection.t new file mode 100644 index 0000000..4457dbe --- /dev/null +++ b/t/90-impl-selection.t @@ -0,0 +1,67 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +sub clear_load { + delete $Package::{'Stash::'}; + delete $INC{'Package/Stash.pm'}; + delete $INC{'Package/Stash/PP.pm'}; + delete $INC{'Package/Stash/XS.pm'}; +} + +my $has_xs; + +{ + $has_xs = eval "require Package::Stash::XS; 1"; + clear_load; +} + +{ + require Package::Stash; + warn $Package::Stash::IMPLEMENTATION; + is($Package::Stash::IMPLEMENTATION, $has_xs ? 'XS' : 'PP', + "autodetected properly"); + can_ok('Package::Stash', 'new', "and got some methods"); + clear_load; +} + +{ + $ENV{PACKAGE_STASH_IMPLEMENTATION} = 'PP'; + require Package::Stash; + is($Package::Stash::IMPLEMENTATION, 'PP', + "autodetected properly"); + can_ok('Package::Stash', 'new', "and got some methods"); + clear_load; +} + +SKIP: { + skip "no XS", 2 unless $has_xs; + $ENV{PACKAGE_STASH_IMPLEMENTATION} = 'XS'; + require Package::Stash; + is($Package::Stash::IMPLEMENTATION, 'XS', + "autodetected properly"); + can_ok('Package::Stash', 'new', "and got some methods"); + clear_load; +} + +{ + $Package::Stash::IMPLEMENTATION = 'PP'; + require Package::Stash; + is($Package::Stash::IMPLEMENTATION, 'PP', + "autodetected properly"); + can_ok('Package::Stash', 'new', "and got some methods"); + clear_load; +} + +SKIP: { + skip "no XS", 2 unless $has_xs; + $Package::Stash::IMPLEMENTATION = 'XS'; + require Package::Stash; + is($Package::Stash::IMPLEMENTATION, 'XS', + "autodetected properly"); + can_ok('Package::Stash', 'new', "and got some methods"); + clear_load; +} + +done_testing;