From: Florian Ragwitz <rafl@debian.org>
Date: Tue, 5 Oct 2010 23:15:58 +0000 (+0200)
Subject: Avoid removing previously imported symbols
X-Git-Tag: 1.16~61
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d004fa1854b6970442a2e764b72f54bb0b030050;p=gitmo%2FMoose.git

Avoid removing previously imported symbols
---

diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm
index aca3f3a..d416b98 100644
--- a/lib/Moose/Exporter.pm
+++ b/lib/Moose/Exporter.pm
@@ -51,12 +51,7 @@ sub build_import_methods {
         $is_reexport,
     );
 
-    my $exporter = Sub::Exporter::build_exporter(
-        {
-            exports => $exports,
-            groups  => { default => [':all'] }
-        }
-    );
+    my $exporter = $class->_make_exporter($exports, $is_reexport);
 
     my %methods;
     $methods{import} = $class->_make_import_sub(
@@ -90,6 +85,49 @@ sub build_import_methods {
     return ( $methods{import}, $methods{unimport}, $methods{init_meta} );
 }
 
+sub _make_exporter {
+    my ($class, $exports, $is_reexport) = @_;
+
+    return Sub::Exporter::build_exporter(
+        {
+            exports   => $exports,
+            groups    => { default => [':all'] },
+            installer => sub {
+                my ($arg, $to_export) = @_;
+                my $meta = Class::MOP::class_of($arg->{into});
+
+                goto &Sub::Exporter::default_installer unless $meta;
+
+                # don't overwrite existing symbols with our magically flagged
+                # version of it if we would install the same sub that's already
+                # in the importer
+
+                my @filtered_to_export;
+                my %installed;
+                for (my $i = 0; $i < @{ $to_export }; $i += 2) {
+                    my ($as, $cv) = @{ $to_export }[$i, $i + 1];
+
+                    next if !ref($as)
+                         && $meta->has_package_symbol('&' . $as)
+                         && $meta->get_package_symbol('&' . $as) == $cv;
+
+                    push @filtered_to_export, $as, $cv;
+                    $installed{$as} = 1 unless ref $as;
+                }
+
+                Sub::Exporter::default_installer($arg, \@filtered_to_export);
+
+                for my $name ( keys %{$is_reexport} ) {
+                    no strict 'refs';
+                    no warnings 'once';
+                    next unless exists $installed{$name};
+                    _flag_as_reexport( \*{ join q{::}, $arg->{into}, $name } );
+                }
+            },
+        }
+    );
+}
+
 {
     my $seen = {};
 
@@ -416,12 +454,6 @@ sub _make_import_sub {
         }
 
         $class->$exporter( $extra, @args );
-
-        for my $name ( keys %{$is_reexport} ) {
-            no strict 'refs';
-            no warnings 'once';
-            _flag_as_reexport( \*{ join q{::}, $CALLER, $name } );
-        }
     };
 }
 
diff --git a/t/010_basics/009_import_unimport.t b/t/010_basics/009_import_unimport.t
index 89bab82..95caad9 100644
--- a/t/010_basics/009_import_unimport.t
+++ b/t/010_basics/009_import_unimport.t
@@ -73,4 +73,28 @@ ok(!Bar->can($_), '... Bar can no longer do ' . $_) for @moose_type_constraint_e
 
 can_ok( 'Baz', 'blessed' );
 
+{
+    package Moo;
+
+    use Scalar::Util qw( blessed );
+    use Moose;
+
+    no Moose;
+}
+
+can_ok( 'Moo', 'blessed' );
+
+my $blessed;
+{
+    package Quux;
+
+    use Scalar::Util qw( blessed );
+    use Moose blessed => { -as => \$blessed };
+
+    no Moose;
+}
+
+can_ok( 'Quux', 'blessed' );
+is( $blessed, \&Scalar::Util::blessed );
+
 done_testing;