X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fnamespace%2Fclean.pm;h=76bb92ebd3ae9d4a77c284b5db9967c619221d1a;hb=226432f602f11579ef0d87d70bbe31547bbd66aa;hp=d7c9a1076c55714e7ccbba4e9801316fcfcf19b4;hpb=472d4b1e844e78b06c74e5792999e388a886c5fe;p=p5sagit%2Fnamespace-clean.git

diff --git a/lib/namespace/clean.pm b/lib/namespace/clean.pm
index d7c9a10..76bb92e 100644
--- a/lib/namespace/clean.pm
+++ b/lib/namespace/clean.pm
@@ -9,18 +9,20 @@ namespace::clean - Keep imports and functions out of your namespace
 use warnings;
 use strict;
 
-use vars              qw( $VERSION $STORAGE_VAR );
-use Symbol            qw( qualify_to_ref );
-use Filter::EOF;
+use vars        qw( $VERSION $STORAGE_VAR $SCOPE_HOOK_KEY $SCOPE_EXPLICIT );
+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.05
+0.11
 
 =cut
 
-$VERSION     = 0.05;
-$STORAGE_VAR = '__NAMESPACE_CLEAN_STORAGE';
+$VERSION         = '0.11';
+$STORAGE_VAR     = '__NAMESPACE_CLEAN_STORAGE';
 
 =head1 SYNOPSIS
 
@@ -55,6 +57,8 @@ $STORAGE_VAR = '__NAMESPACE_CLEAN_STORAGE';
 
 =head1 DESCRIPTION
 
+=head2 Keeping packages clean
+
 When you define a function, or import one, into a Perl package, it will
 naturally also be available as a method. This does not per se cause
 problems, but it can complicate subclassing and, for example, plugin
@@ -79,6 +83,60 @@ be a module exporting an C<import> method along with some functions:
 If you just want to C<-except> a single sub, you can pass it directly.
 For more than one value you have to use an array reference.
 
+=head2 Explicitely removing functions when your scope is compiled
+
+It is also possible to explicitely tell C<namespace::clean> what packages
+to remove when the surrounding scope has finished compiling. Here is an
+example:
+
+  package Foo;
+  use strict;
+
+  # blessed NOT available
+
+  sub my_class {
+      use Scalar::Util qw( blessed );
+      use namespace::clean qw( blessed );
+
+      # blessed available
+      return blessed shift;
+  }
+
+  # blessed NOT available
+
+=head2 Moose
+
+When using C<namespace::clean> together with L<Moose> you want to keep
+the installed C<meta> method. So your classes should look like:
+
+  package Foo;
+  use Moose;
+  use namespace::clean -except => 'meta';
+  ...
+
+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
@@ -86,63 +144,140 @@ appropriate place.
 
 =cut
 
-=head2 import
+=head2 clean_subroutines
+
+This exposes the actual subroutine-removal logic.
 
-Makes a snapshot of the current defined functions and registers a 
-L<Filter::EOF> cleanup routine to remove those symbols at the end 
-of the compile-time.
+  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
 
-sub import {
-    my ($pragma, %args) = @_;
+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';
+
+        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;
+            }
 
-    # calling class, all current functions and our storage
-    my $cleanee   = caller;
-    my $functions = $pragma->get_functions($cleanee);
-    my $store     = $pragma->get_class_store($cleanee);
+            local *__tmp;
 
-    # except parameter can be array ref or single value
-    my %except = map {( $_ => 1 )} (
-        $args{ -except }
-        ? ( ref $args{ -except } eq 'ARRAY' ? @{ $args{ -except } } : $args{ -except } )
-        : ()
-    );
+            # keep original value to restore non-code slots
+            {   no warnings 'uninitialized';    # fix possible unimports
+                *__tmp = *{ ${ "${cleanee}::" }{ $f } };
+                delete ${ "${cleanee}::" }{ $f };
+            }
 
-    # register symbols for removal, if they have a CODE entry
-    for my $f (keys %$functions) {
-        next if     $except{ $f };
-        next unless    $functions->{ $f } 
-                and *{ $functions->{ $f } }{CODE};
-        $store->{remove}{ $f } = 1;
+          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 };
+            }
+        }
+        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 };
+        }
     }
+};
 
-    # register EOF handler on first call to import
-    unless ($store->{handler_is_installed}) {
-        Filter::EOF->on_eof_call(sub {
-          SYMBOL:
-            for my $f (keys %{ $store->{remove} }) {
+sub clean_subroutines {
+    my ($nc, $cleanee, @subs) = @_;
+    $RemoveSubs->($cleanee, {}, @subs);
+}
 
-                # ignore already removed symbols
-                next SYMBOL if $store->{exclude}{ $f };
-                no strict 'refs';
+=head2 import
 
-                # keep original value to restore non-code slots
-                local *__tmp = *{ ${ "${cleanee}::" }{ $f } };
-                delete ${ "${cleanee}::" }{ $f };
+Makes a snapshot of the current defined functions and installs a
+L<B::Hooks::EndOfScope> hook in the current scope to invoke the cleanups.
 
-              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 };
-                }
-            }
-        });
-        $store->{handler_is_installed} = 1;
+=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;
+        }
     }
 
-    return 1;
+    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);
+
+        # 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    $functions->{ $f } 
+                    and *{ $functions->{ $f } }{CODE};
+            $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;
+    }
 }
 
 =head2 unimport
@@ -156,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);
 
@@ -206,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 
@@ -225,7 +366,7 @@ use C<undef> instead.
 
 =head1 SEE ALSO
 
-L<Filter::EOF>
+L<B::Hooks::EndOfScope>
 
 =head1 AUTHOR AND COPYRIGHT
 
@@ -239,4 +380,5 @@ it under the same terms as perl itself.
 
 =cut
 
-1;
+no warnings;
+'Danger! Laws of Thermodynamics may not apply.'