X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fnamespace%2Fclean.pm;h=d31d2a82ba6d8ef568e79d8df7f67f3ea5a2740b;hb=d6aecfbf3b72bb46d52032f696415e93a22dc5ab;hp=1f370fe68260a6a802ad23a19ddfd63fd8e154ae;hpb=61c4bce7e7b6585613a8b01119cfe88ede232bca;p=p5sagit%2Fnamespace-clean.git

diff --git a/lib/namespace/clean.pm b/lib/namespace/clean.pm
index 1f370fe..d31d2a8 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 B::Hooks::EndOfScope;
+use Stash::Manip;
+use Sub::Identify qw(sub_fullname);
+use Sub::Name qw(subname);
 
 =head1 VERSION
 
-0.11
+0.13
 
 =cut
 
-$VERSION         = '0.11';
+$VERSION         = '0.14';
 $STORAGE_VAR     = '__NAMESPACE_CLEAN_STORAGE';
 
 =head1 SYNOPSIS
@@ -159,29 +161,31 @@ my $RemoveSubs = sub {
 
     my $cleanee = shift;
     my $store   = shift;
+    my $cleanee_stash = Stash::Manip->new($cleanee);
+    my $deleted_stash = Stash::Manip->new("namespace::clean::deleted::$cleanee");
   SYMBOL:
     for my $f (@_) {
-
+        my $variable = "&$f";
         # ignore already removed symbols
         next SYMBOL if $store->{exclude}{ $f };
-        no strict 'refs';
-
-        local *__tmp;
 
-        # keep original value to restore non-code slots
-        {   no warnings 'uninitialized';    # fix possible unimports
-            *__tmp = *{ ${ "${cleanee}::" }{ $f } };
-            delete ${ "${cleanee}::" }{ $f };
+        next SYMBOL unless $cleanee_stash->has_package_symbol($variable);
+
+        if (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.
+            my $sub = $cleanee_stash->get_package_symbol($variable);
+            if ( sub_fullname($sub) eq ($cleanee_stash->name . "::$f") ) {
+                my $new_fq = $deleted_stash->name . "::$f";
+                subname($new_fq, $sub);
+                $deleted_stash->add_package_symbol($variable, $sub);
+            }
         }
 
-      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 };
-        }
+        $cleanee_stash->remove_package_symbol($variable);
     }
 };
 
@@ -227,6 +231,7 @@ sub import {
         # calling class, all current functions and our storage
         my $functions = $pragma->get_functions($cleanee);
         my $store     = $pragma->get_class_store($cleanee);
+        my $stash     = Stash::Manip->new($cleanee);
 
         # except parameter can be array ref or single value
         my %except = map {( $_ => 1 )} (
@@ -238,8 +243,7 @@ sub import {
         # 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};
+            next unless $stash->has_package_symbol("&$f");
             $store->{remove}{ $f } = 1;
         }
 
@@ -292,8 +296,8 @@ information about function names included and excluded from removal.
 
 sub get_class_store {
     my ($pragma, $class) = @_;
-    no strict 'refs';
-    return \%{ "${class}::${STORAGE_VAR}" };
+    my $stash = Stash::Manip->new($class);
+    return $stash->get_package_symbol("%$STORAGE_VAR");
 }
 
 =head2 get_functions
@@ -307,12 +311,10 @@ reference to the symbol as value.
 sub get_functions {
     my ($pragma, $class) = @_;
 
+    my $stash = Stash::Manip->new($class);
     return {
-        map  { @$_ }                                        # key => value
-        grep { *{ $_->[1] }{CODE} }                         # only functions
-        map  { [$_, qualify_to_ref( $_, $class )] }         # get globref
-        grep { $_ !~ /::$/ }                                # no packages
-        do   { no strict 'refs'; keys %{ "${class}::" } }   # symbol entries
+        map { $_ => $stash->get_package_symbol("&$_") }
+            $stash->list_all_package_symbols('CODE')
     };
 }