X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fnamespace%2Fclean.pm;h=e80413b2ab1f9969d18774bdbc8b7876e7048cc4;hb=18377f5b;hp=819761896a9dc7e1bef7911857b4a4cdcf0024df;hpb=9887772bacd28d3ead3728d5a1c0c35b5fcdf794;p=p5sagit%2Fnamespace-clean.git

diff --git a/lib/namespace/clean.pm b/lib/namespace/clean.pm
index 8197618..e80413b 100644
--- a/lib/namespace/clean.pm
+++ b/lib/namespace/clean.pm
@@ -1,53 +1,233 @@
 package namespace::clean;
-# ABSTRACT: Keep imports and functions out of your namespace
 
 use warnings;
 use strict;
 
-use vars qw( $STORAGE_VAR );
-use Package::Stash;
+our $VERSION = '0.25';
+$VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
 
-$STORAGE_VAR = '__NAMESPACE_CLEAN_STORAGE';
+our $STORAGE_VAR = '__NAMESPACE_CLEAN_STORAGE';
 
+use B::Hooks::EndOfScope 'on_scope_end';
+
+# FIXME This is a crock of shit, needs to go away
+# currently here to work around https://rt.cpan.org/Ticket/Display.html?id=74151
+# kill with fire when PS::XS is *finally* fixed
 BEGIN {
-  if (eval {
-    require B::Hooks::EndOfScope;
-    B::Hooks::EndOfScope->VERSION('0.07');
-    1
-  } ) {
-    B::Hooks::EndOfScope->import('on_scope_end');
+  my $provider;
+
+  if ( $] < 5.008007 ) {
+    require Package::Stash::PP;
+    $provider = 'Package::Stash::PP';
   }
   else {
-    eval <<'PP' or die $@;
+    require Package::Stash;
+    $provider = 'Package::Stash';
+  }
+  eval <<"EOS" or die $@;
 
-  {
-    package namespace::clean::_ScopeGuard;
+sub stash_for (\$) {
+  $provider->new(\$_[0]);
+}
 
-    sub arm { bless [ $_[1] ] }
+1;
 
-    sub DESTROY { $_[0]->[0]->() }
-  }
+EOS
+}
+
+use namespace::clean::_Util qw( DEBUGGER_NEEDS_CV_RENAME DEBUGGER_NEEDS_CV_PIVOT );
+
+# Built-in debugger CV-retrieval fixups necessary before perl 5.15.5:
+# since we are deleting the glob where the subroutine was originally
+# defined, the assumptions below no longer hold.
+#
+# In 5.8.9 ~ 5.13.5 (inclusive) the debugger assumes that a CV can
+# always be found under sub_fullname($sub)
+# Workaround: use sub naming to properly name the sub hidden in the package's
+# deleted-stash
+#
+# In the rest of the range ( ... ~ 5.8.8 and 5.13.6 ~ 5.15.4 ) the debugger
+# assumes the name of the glob passed to entersub can be used to find the CV
+# Workaround: realias the original glob to the deleted-stash slot
+#
+# Can not tie constants to the current value of $^P directly,
+# as the debugger can be enabled during runtime (kinda dubious)
+#
+
+my $RemoveSubs = sub {
+    my $cleanee = shift;
+    my $store   = shift;
+    my $cleanee_stash = stash_for($cleanee);
+    my $deleted_stash;
+
+  SYMBOL:
+    for my $f (@_) {
+
+        # ignore already removed symbols
+        next SYMBOL if $store->{exclude}{ $f };
+
+        my $sub = $cleanee_stash->get_symbol("&$f")
+          or next SYMBOL;
+
+        my $need_debugger_fixup =
+          ( DEBUGGER_NEEDS_CV_RENAME or DEBUGGER_NEEDS_CV_PIVOT )
+            &&
+          $^P
+            &&
+          ref(my $globref = \$cleanee_stash->namespace->{$f}) eq 'GLOB'
+            &&
+         ( $deleted_stash ||= stash_for("namespace::clean::deleted::$cleanee") )
+        ;
+
+        # convince the Perl debugger to work
+        # see the comment on top
+        if ( DEBUGGER_NEEDS_CV_RENAME and $need_debugger_fixup ) {
+          #
+          # Note - both get_subname and set_subname are only compiled when CV_RENAME
+          # is true ( the 5.8.9 ~ 5.12 range ). On other perls this entire block is
+          # constant folded away, and so are the definitions in ::_Util
+          #
+          # Do not be surprised that they are missing without DEBUGGER_NEEDS_CV_RENAME
+          #
+          namespace::clean::_Util::get_subname( $sub ) eq  ( $cleanee_stash->name . "::$f" )
+            and
+          $deleted_stash->add_symbol(
+            "&$f",
+            namespace::clean::_Util::set_subname( $deleted_stash->name . "::$f", $sub ),
+          );
+        }
+        elsif ( DEBUGGER_NEEDS_CV_PIVOT and $need_debugger_fixup ) {
+          $deleted_stash->add_symbol("&$f", $sub);
+        }
+
+        my @symbols = map {
+            my $name = $_ . $f;
+            my $def = $cleanee_stash->get_symbol($name);
+            defined($def) ? [$name, $def] : ()
+        } '$', '@', '%', '';
+
+        $cleanee_stash->remove_glob($f);
+
+        # if this perl needs no renaming trick we need to
+        # rename the original glob after the fact
+        DEBUGGER_NEEDS_CV_PIVOT
+          and
+        $need_debugger_fixup
+          and
+        *$globref = $deleted_stash->namespace->{$f};
+
+        $cleanee_stash->add_symbol(@$_) for @symbols;
+    }
+};
+
+sub clean_subroutines {
+    my ($nc, $cleanee, @subs) = @_;
+    $RemoveSubs->($cleanee, {}, @subs);
+}
+
+sub import {
+    my ($pragma, @args) = @_;
 
-  use Tie::Hash ();
+    my (%args, $is_explicit);
 
-  sub on_scope_end (&) {
-    $^H |= 0x020000;
+  ARG:
+    while (@args) {
+
+        if ($args[0] =~ /^\-/) {
+            my $key = shift @args;
+            my $value = shift @args;
+            $args{ $key } = $value;
+        }
+        else {
+            $is_explicit++;
+            last ARG;
+        }
+    }
 
-    if( my $stack = tied( %^H ) ) {
-      push @$stack, namespace::clean::_ScopeGuard->arm(shift);
+    my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
+    if ($is_explicit) {
+        on_scope_end {
+            $RemoveSubs->($cleanee, {}, @args);
+        };
     }
     else {
-      tie( %^H, 'Tie::ExtraHash', namespace::clean::_ScopeGuard->arm(shift) );
+
+        # calling class, all current functions and our storage
+        my $functions = $pragma->get_functions($cleanee);
+        my $store     = $pragma->get_class_store($cleanee);
+        my $stash     = stash_for($cleanee);
+
+        # except parameter can be array ref or single value
+        my %except = map {( $_ => 1 )} (
+            $args{ -except }
+            ? ( ref $args{ -except } eq 'ARRAY' ? @{ $args{ -except } } : $args{ -except } )
+            : ()
+        );
+
+        # register symbols for removal, if they have a CODE entry
+        for my $f (keys %$functions) {
+            next if     $except{ $f };
+            next unless $stash->has_symbol("&$f");
+            $store->{remove}{ $f } = 1;
+        }
+
+        # register EOF handler on first call to import
+        unless ($store->{handler_is_installed}) {
+            on_scope_end {
+                $RemoveSubs->($cleanee, $store, keys %{ $store->{remove} });
+            };
+            $store->{handler_is_installed} = 1;
+        }
+
+        return 1;
     }
-  }
+}
 
-  1;
+sub unimport {
+    my ($pragma, %args) = @_;
 
-PP
+    # the calling class, the current functions and our storage
+    my $cleanee   = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
+    my $functions = $pragma->get_functions($cleanee);
+    my $store     = $pragma->get_class_store($cleanee);
 
-  }
+    # register all unknown previous functions as excluded
+    for my $f (keys %$functions) {
+        next if $store->{remove}{ $f }
+             or $store->{exclude}{ $f };
+        $store->{exclude}{ $f } = 1;
+    }
+
+    return 1;
+}
+
+sub get_class_store {
+    my ($pragma, $class) = @_;
+    my $stash = stash_for($class);
+    my $var = "%$STORAGE_VAR";
+    $stash->add_symbol($var, {})
+        unless $stash->has_symbol($var);
+    return $stash->get_symbol($var);
+}
+
+sub get_functions {
+    my ($pragma, $class) = @_;
+
+    my $stash = stash_for($class);
+    return {
+        map { $_ => $stash->get_symbol("&$_") }
+            $stash->list_all_symbols('CODE')
+    };
 }
 
+'Danger! Laws of Thermodynamics may not apply.'
+
+__END__
+
+=head1 NAME
+
+namespace::clean - Keep imports and functions out of your namespace
+
 =head1 SYNOPSIS
 
   package Foo;
@@ -161,7 +341,9 @@ option like this:
 If you don't care about C<namespace::clean>s discover-and-C<-except> logic, and
 just want to remove subroutines, try L</clean_subroutines>.
 
-=method clean_subroutines
+=head1 METHODS
+
+=head2 clean_subroutines
 
 This exposes the actual subroutine-removal logic.
 
@@ -172,145 +354,13 @@ subroutines B<immediately> and not wait for scope end. If you want to have this
 effect at a specific time (e.g. C<namespace::clean> acts on scope compile end)
 it is your responsibility to make sure it runs at that time.
 
-=cut
-
-my $sub_utils_loaded;
-my $DebuggerRename = sub {
-  my ($f, $sub, $cleanee_stash, $deleted_stash) = @_;
-
-  if (! defined $sub_utils_loaded ) {
-    $sub_utils_loaded = do {
-      my $sn_ver = 0.04;
-      eval { require Sub::Name; Sub::Name->VERSION($sn_ver) }
-        or die "Sub::Name $sn_ver required when running under -d or equivalent: $@";
-
-      my $si_ver = 0.04;
-      eval { require Sub::Identify; Sub::Identify->VERSION($si_ver) }
-        or die "Sub::Identify $si_ver required when running under -d or equivalent: $@";
-
-      1;
-    } ? 1 : 0;
-  }
-
-  if ( Sub::Identify::sub_fullname($sub) eq ($cleanee_stash->name . "::$f") ) {
-    my $new_fq = $deleted_stash->name . "::$f";
-    Sub::Name::subname($new_fq, $sub);
-    $deleted_stash->add_symbol("&$f", $sub);
-  }
-};
-
-my $RemoveSubs = sub {
-    my $cleanee = shift;
-    my $store   = shift;
-    my $cleanee_stash = Package::Stash->new($cleanee);
-    my $deleted_stash;
-
-  SYMBOL:
-    for my $f (@_) {
-
-        # ignore already removed symbols
-        next SYMBOL if $store->{exclude}{ $f };
-
-        my $sub = $cleanee_stash->get_symbol("&$f")
-          or next SYMBOL;
-
-        if ($^P and ref(\$cleanee_stash->namespace->{$f}) eq 'GLOB') {
-            # convince the Perl debugger to work
-            # it assumes that sub_fullname($sub) can always be used to find the CV again
-            # since we are deleting the glob where the subroutine was originally
-            # defined, that assumption no longer holds, so we need to move it
-            # elsewhere and point the CV's name to the new glob.
-            $DebuggerRename->(
-              $f,
-              $sub,
-              $cleanee_stash,
-              $deleted_stash ||= Package::Stash->new("namespace::clean::deleted::$cleanee"),
-            );
-        }
-
-        my @symbols = map {
-            my $name = $_ . $f;
-            my $def = $cleanee_stash->get_symbol($name);
-            defined($def) ? [$name, $def] : ()
-        } '$', '@', '%', '';
-
-        $cleanee_stash->remove_glob($f);
-
-        $cleanee_stash->add_symbol(@$_) for @symbols;
-    }
-};
-
-sub clean_subroutines {
-    my ($nc, $cleanee, @subs) = @_;
-    $RemoveSubs->($cleanee, {}, @subs);
-}
-
-=method import
+=head2 import
 
 Makes a snapshot of the current defined functions and installs a
 L<B::Hooks::EndOfScope> hook in the current scope to invoke the cleanups.
 
-=cut
-
-sub import {
-    my ($pragma, @args) = @_;
-
-    my (%args, $is_explicit);
-
-  ARG:
-    while (@args) {
-
-        if ($args[0] =~ /^\-/) {
-            my $key = shift @args;
-            my $value = shift @args;
-            $args{ $key } = $value;
-        }
-        else {
-            $is_explicit++;
-            last ARG;
-        }
-    }
-
-    my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
-    if ($is_explicit) {
-        on_scope_end {
-            $RemoveSubs->($cleanee, {}, @args);
-        };
-    }
-    else {
-
-        # calling class, all current functions and our storage
-        my $functions = $pragma->get_functions($cleanee);
-        my $store     = $pragma->get_class_store($cleanee);
-        my $stash     = Package::Stash->new($cleanee);
 
-        # except parameter can be array ref or single value
-        my %except = map {( $_ => 1 )} (
-            $args{ -except }
-            ? ( ref $args{ -except } eq 'ARRAY' ? @{ $args{ -except } } : $args{ -except } )
-            : ()
-        );
-
-        # register symbols for removal, if they have a CODE entry
-        for my $f (keys %$functions) {
-            next if     $except{ $f };
-            next unless $stash->has_symbol("&$f");
-            $store->{remove}{ $f } = 1;
-        }
-
-        # register EOF handler on first call to import
-        unless ($store->{handler_is_installed}) {
-            on_scope_end {
-                $RemoveSubs->($cleanee, $store, keys %{ $store->{remove} });
-            };
-            $store->{handler_is_installed} = 1;
-        }
-
-        return 1;
-    }
-}
-
-=method unimport
+=head2 unimport
 
 This method will be called when you do a
 
@@ -318,60 +368,17 @@ This method will be called when you do a
 
 It will start a new section of code that defines functions to clean up.
 
-=cut
-
-sub unimport {
-    my ($pragma, %args) = @_;
-
-    # the calling class, the current functions and our storage
-    my $cleanee   = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
-    my $functions = $pragma->get_functions($cleanee);
-    my $store     = $pragma->get_class_store($cleanee);
-
-    # register all unknown previous functions as excluded
-    for my $f (keys %$functions) {
-        next if $store->{remove}{ $f }
-             or $store->{exclude}{ $f };
-        $store->{exclude}{ $f } = 1;
-    }
-
-    return 1;
-}
-
-=method get_class_store
+=head2 get_class_store
 
 This returns a reference to a hash in a passed package containing
 information about function names included and excluded from removal.
 
-=cut
-
-sub get_class_store {
-    my ($pragma, $class) = @_;
-    my $stash = Package::Stash->new($class);
-    my $var = "%$STORAGE_VAR";
-    $stash->add_symbol($var, {})
-        unless $stash->has_symbol($var);
-    return $stash->get_symbol($var);
-}
-
-=method get_functions
+=head2 get_functions
 
 Takes a class as argument and returns all currently defined functions
 in it as a hash reference with the function name as key and a typeglob
 reference to the symbol as value.
 
-=cut
-
-sub get_functions {
-    my ($pragma, $class) = @_;
-
-    my $stash = Package::Stash->new($class);
-    return {
-        map { $_ => $stash->get_symbol("&$_") }
-            $stash->list_all_symbols('CODE')
-    };
-}
-
 =head1 IMPLEMENTATION DETAILS
 
 This module works through the effect that a
@@ -389,14 +396,6 @@ will be stable in future releases.
 Just for completeness sake, if you want to remove the symbol completely,
 use C<undef> instead.
 
-=head1 CAVEATS
-
-This module is fully functional in a pure-perl environment, where
-L<Variable::Magic>, a L<B::Hooks::EndOfScope> dependency, may not be
-available. However in this case this module falls back to a
-L<tie()|perlfunc/tie> of L<%^H|perlvar/%^H>  which may or may not interfere
-with some crack you may be doing independently of namespace::clean.
-
 =head1 SEE ALSO
 
 L<B::Hooks::EndOfScope>
@@ -405,7 +404,34 @@ L<B::Hooks::EndOfScope>
 
 Many thanks to Matt S Trout for the inspiration on the whole idea.
 
-=cut
+=head1 AUTHORS
 
-no warnings;
-'Danger! Laws of Thermodynamics may not apply.'
+=over
+
+=item *
+
+Robert 'phaylon' Sedlacek <rs@474.at>
+
+=item *
+
+Florian Ragwitz <rafl@debian.org>
+
+=item *
+
+Jesse Luehrs <doy@tozt.net>
+
+=item *
+
+Peter Rabbitson <ribasushi@cpan.org>
+
+=item *
+
+Father Chrysostomos <sprout@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2011 by L</AUTHORS>
+
+This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself.