X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fnamespace%2Fclean.pm;h=8c6a156bbbb544fffcbb02ddf714a0be7e52cce9;hb=32ffc8cb2f6e62f6e9bc9468820ac61d098e71b8;hp=214bbb0f34931e90d03f48da49a78fb1708c651f;hpb=cc1392b6a1432a887bb0f284acfecb932221cd27;p=p5sagit%2Fnamespace-clean.git

diff --git a/lib/namespace/clean.pm b/lib/namespace/clean.pm
index 214bbb0..8c6a156 100644
--- a/lib/namespace/clean.pm
+++ b/lib/namespace/clean.pm
@@ -10,16 +10,18 @@ use warnings;
 use strict;
 
 use vars        qw( $VERSION $STORAGE_VAR $SCOPE_HOOK_KEY $SCOPE_EXPLICIT );
-use Symbol      qw( qualify_to_ref );
+use Symbol      qw( qualify_to_ref gensym );
 use B::Hooks::EndOfScope;
+use Sub::Identify qw(sub_fullname);
+use Sub::Name qw(subname);
 
 =head1 VERSION
 
-0.08
+0.13
 
 =cut
 
-$VERSION         = 0.09;
+$VERSION         = '0.13';
 $STORAGE_VAR     = '__NAMESPACE_CLEAN_STORAGE';
 
 =head1 SYNOPSIS
@@ -114,6 +116,27 @@ the installed C<meta> method. So your classes should look like:
 
 Same goes for L<Moose::Role>.
 
+=head2 Cleaning other packages
+
+You can tell C<namespace::clean> that you want to clean up another package
+instead of the one importing. To do this you have to pass in the C<-cleanee>
+option like this:
+
+  package My::MooseX::namespace::clean;
+  use strict;
+
+  use namespace::clean (); # no cleanup, just load
+
+  sub import {
+      namespace::clean->import(
+        -cleanee => scalar(caller),
+        -except  => 'meta',
+      );
+  }
+
+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>.
+
 =head1 METHODS
 
 You shouldn't need to call any of these. Just C<use> the package at the
@@ -121,51 +144,104 @@ appropriate place.
 
 =cut
 
-=head2 import
+=head2 clean_subroutines
 
-Makes a snapshot of the current defined functions and installs a
-L<B::Hooks::EndOfScope> hook in the current scope to invoke the cleanups.
+This exposes the actual subroutine-removal logic.
+
+  namespace::clean->clean_subroutines($cleanee, qw( subA subB ));
+
+will remove C<subA> and C<subB> from C<$cleanee>. Note that this will remove the
+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 $RemoveSubs = sub {
+
     my $cleanee = shift;
     my $store   = shift;
   SYMBOL:
     for my $f (@_) {
+        my $fq = "${cleanee}::$f";
 
         # ignore already removed symbols
         next SYMBOL if $store->{exclude}{ $f };
         no strict 'refs';
 
-        # keep original value to restore non-code slots
-        {   no warnings 'uninitialized';    # fix possible unimports
-            local *__tmp = *{ ${ "${cleanee}::" }{ $f } };
-            delete ${ "${cleanee}::" }{ $f };
+        next SYMBOL unless exists ${ "${cleanee}::" }{ $f };
+
+        if (ref(\${ "${cleanee}::" }{ $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.
+            my $sub = \&$fq;
+            if ( sub_fullname($sub) eq $fq ) {
+                my $new_fq = "namespace::clean::deleted::$fq";
+                subname($new_fq, $sub);
+                *{$new_fq} = $sub;
+            }
+
+            local *__tmp;
+
+            # keep original value to restore non-code slots
+            {   no warnings 'uninitialized';    # fix possible unimports
+                *__tmp = *{ ${ "${cleanee}::" }{ $f } };
+                delete ${ "${cleanee}::" }{ $f };
+            }
+
+          SLOT:
+            # restore non-code slots to symbol.
+            # omit the FORMAT slot, since perl erroneously puts it into the
+            # SCALAR slot of the new glob.
+            for my $t (qw( SCALAR ARRAY HASH IO )) {
+                next SLOT unless defined *__tmp{ $t };
+                *{ "${cleanee}::$f" } = *__tmp{ $t };
+            }
         }
-
-      SLOT:
-        # restore non-code slots to symbol
-        for my $t (qw( SCALAR ARRAY HASH IO FORMAT )) {
-            next SLOT unless defined *__tmp{ $t };
-            *{ "${cleanee}::$f" } = *__tmp{ $t };
+        else {
+            # A non-glob in the stash is assumed to stand for some kind
+            # of function.  So far they all do, but the core might change
+            # this some day.  Watch perl5-porters.
+            delete ${ "${cleanee}::" }{ $f };
         }
     }
 };
 
+sub clean_subroutines {
+    my ($nc, $cleanee, @subs) = @_;
+    $RemoveSubs->($cleanee, {}, @subs);
+}
+
+=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);
-    if (@args and $args[0] =~ /^\-/) {
-        %args = @args;
-        @args = ();
-    }
-    elsif (@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 = caller;
+    my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
     if ($is_explicit) {
         on_scope_end {
             $RemoveSubs->($cleanee, {}, @args);
@@ -215,10 +291,10 @@ It will start a new section of code that defines functions to clean up.
 =cut
 
 sub unimport {
-    my ($pragma) = @_;
+    my ($pragma, %args) = @_;
 
     # the calling class, the current functions and our storage
-    my $cleanee   = caller;
+    my $cleanee   = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
     my $functions = $pragma->get_functions($cleanee);
     my $store     = $pragma->get_class_store($cleanee);
 
@@ -265,6 +341,12 @@ sub get_functions {
     };
 }
 
+=head1 BUGS
+
+C<namespace::clean> will clobber any formats that have the same name as
+a deleted sub. This is due to a bug in perl that makes it impossible to
+re-assign the FORMAT ref into a new glob.
+
 =head1 IMPLEMENTATION DETAILS
 
 This module works through the effect that a