Might as well be explicit about requiring namespace::clean 0.08 since

[gitmo/Moose.git] / lib / Moose / Exporter.pm

diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm
index 4862563..2fad886 100644 (file)
--- a/lib/Moose/Exporter.pm
+++ b/lib/Moose/Exporter.pm
@@ -4,6 +4,7 @@ use strict;
 use warnings;
 
 use Class::MOP;
+use namespace::clean 0.08 ();
 use Sub::Exporter;
 
 
@@ -19,23 +20,80 @@ sub get_caller{
                     : caller($offset);
 }
 
+my %EXPORT_SPEC;
+sub build_import_methods {
+    my $class = shift;
+    my %args  = @_;
+
+    my $exporting_package = caller();
+
+    $EXPORT_SPEC{$exporting_package} = \%args;
+
+    my ( $exporter, $exported )
+        = $class->_build_exporter( exporting_package => $exporting_package,
+        %args );
+
+    my $import = sub {
+        my $caller = Moose::Exporter->get_caller(@_);
+
+        # this works because both pragmas set $^H (see perldoc perlvar)
+        # which affects the current compilation - i.e. the file who use'd
+        # us - which is why we don't need to do anything special to make
+        # it affect that file rather than this one (which is already compiled)
+
+        strict->import;
+        warnings->import;
+
+        # we should never export to main
+        if ( $caller eq 'main' ) {
+            warn
+                qq{$exporting_package does not export its sugar to the 'main' package.\n};
+            return;
+        }
+
+        if ( $exporting_package->can('_init_meta') ) {
+            $exporting_package->_init_meta(
+                for_class => $caller,
+                %{ $args{init_meta_args} || {} }
+            );
+        }
+
+        goto $exporter;
+    };
+
+    # [12:24]  <mst> yes. that's horrible. I know. but it should work.
+    #
+    # This will hopefully be replaced in the future once
+    # namespace::clean has an API for it.
+    my $unimport = sub {
+        @_ = ( 'namespace::clean', @{ $exported } );
+
+        goto &namespace::clean::import;
+    };
+
+    no strict 'refs';
+    *{ $exporting_package . '::import' } = $import;
+    *{ $exporting_package . '::unimport' } = $unimport;
+}
+
 my %EXPORTED;
-sub build_exporter {
+sub _build_exporter {
     my $class = shift;
     my %args  = @_;
 
-    my $exporting_pkg = caller();
+    my $exporting_package = $args{exporting_package};
 
+    my @exported_names;
     my %exports;
     for my $name ( @{ $args{with_caller} } ) {
-        my $sub = do { no strict 'refs'; \&{ $exporting_pkg . '::' . $name } };
+        my $sub = do { no strict 'refs'; \&{ $exporting_package . '::' . $name } };
 
         my $wrapped = Class::MOP::subname(
-            $exporting_pkg . '::' . $name => sub { $sub->( scalar caller(), @_ ) } );
+            $exporting_package . '::' . $name => sub { $sub->( scalar caller(), @_ ) } );
 
         $exports{$name} = sub { $wrapped };
 
-        push @{ $EXPORTED{$exporting_pkg} }, $name;
+        push @exported_names, $name;
     }
 
     for my $name ( @{ $args{as_is} } ) {
@@ -46,40 +104,22 @@ sub build_exporter {
             $name = ( Class::MOP::get_code_info($name) )[1];
         }
         else {
-            $sub = do { no strict 'refs'; \&{ $exporting_pkg . '::' . $name } };
+            $sub = do { no strict 'refs'; \&{ $exporting_package . '::' . $name } };
 
-            push @{ $EXPORTED{$exporting_pkg} }, $name;
+            push @exported_names, $name;
         }
 
         $exports{$name} = sub { $sub };
     }
 
-    return Sub::Exporter::build_exporter(
+    my $exporter = Sub::Exporter::build_exporter(
         {
             exports => \%exports,
             groups  => { default => [':all'] }
         }
     );
-}
-
-sub remove_keywords {
-    my $class = shift;
-    my %args  = @_;
-
-    no strict 'refs';
-
-    for my $name ( @{ $EXPORTED{ $args{source} } } ) {
-        if ( defined &{ $args{from} . '::' . $name } ) {
-            my $keyword = \&{ $args{from} . '::' . $name };
 
-            # make sure it is from us
-            my ($pkg_name) = Class::MOP::get_code_info($keyword);
-            next if $pkg_name ne $args{source};
-
-            # and if it is from us, then undef the slot
-            delete ${ $args{from} . '::' }{$name};
-        }
-    }
+    return $exporter, \@exported_names;
 }
 
 1;