X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FExporter.pm;h=6644ae9975b24a7841a85434273c4f06bf8e90e4;hb=59f5bbde66d61d15b684be88d138fd798ba851d0;hp=ac983767dc1087f338ee9ed83b6d968097bf39a9;hpb=085fba615666e2297e8bc2d965b37ce4f0eb1182;p=gitmo%2FMoose.git

diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm
index ac98376..6644ae9 100644
--- a/lib/Moose/Exporter.pm
+++ b/lib/Moose/Exporter.pm
@@ -3,26 +3,44 @@ package Moose::Exporter;
 use strict;
 use warnings;
 
+our $VERSION   = '0.64';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
 use Class::MOP;
-use namespace::clean 0.08 ();
-use List::MoreUtils qw( uniq );
+use List::MoreUtils qw( first_index uniq );
+use Moose::Util::MetaRole;
 use Sub::Exporter;
 
 
 my %EXPORT_SPEC;
 
+sub setup_import_methods {
+    my ( $class, %args ) = @_;
+
+    my $exporting_package = $args{exporting_package} ||= caller();
+
+    my ( $import, $unimport ) = $class->build_import_methods(%args);
+
+    no strict 'refs';
+    *{ $exporting_package . '::import' }   = $import;
+    *{ $exporting_package . '::unimport' } = $unimport;
+}
+
 sub build_import_methods {
-    my $class = shift;
-    my %args  = @_;
+    my ( $class, %args ) = @_;
 
-    my $exporting_package = caller();
+    my $exporting_package = $args{exporting_package} ||= caller();
 
     $EXPORT_SPEC{$exporting_package} = \%args;
 
     my @exports_from = $class->_follow_also( $exporting_package );
 
-    my $exports
-        = $class->_process_exports( $exporting_package, @exports_from );
+    my $export_recorder = {};
+
+    my ( $exports, $is_removable )
+        = $class->_make_sub_exporter_params(
+        [ $exporting_package, @exports_from ], $export_recorder );
 
     my $exporter = Sub::Exporter::build_exporter(
         {
@@ -31,23 +49,26 @@ sub build_import_methods {
         }
     );
 
-    my $import = $class->_make_import_sub($exporter);
+    # $args{_export_to_main} exists for backwards compat, because
+    # Moose::Util::TypeConstraints did export to main (unlike Moose &
+    # Moose::Role).
+    my $import = $class->_make_import_sub( $exporting_package, $exporter,
+        \@exports_from, $args{_export_to_main} );
 
-    my $unimport = $class->_make_unimport_sub( [ keys %{$exports} ] );
+    my $unimport = $class->_make_unimport_sub( $exporting_package, $exports,
+        $is_removable, $export_recorder );
 
-    no strict 'refs';
-    *{ $exporting_package . '::import' }   = $import;
-    *{ $exporting_package . '::unimport' } = $unimport;
+    return ( $import, $unimport )
 }
 
 {
-    my %seen;
+    my $seen = {};
 
     sub _follow_also {
         my $class             = shift;
         my $exporting_package = shift;
 
-        %seen = ( $exporting_package => 1 );
+        local %$seen = ( $exporting_package => 1 );
 
         return uniq( _follow_also_real($exporting_package) );
     }
@@ -55,7 +76,7 @@ sub build_import_methods {
     sub _follow_also_real {
         my $exporting_package = shift;
 
-        die "Package in also ($exporting_package) does not seem to use MooseX::Exporter"
+        die "Package in also ($exporting_package) does not seem to use Moose::Exporter"
             unless exists $EXPORT_SPEC{$exporting_package};
 
         my $also = $EXPORT_SPEC{$exporting_package}{also};
@@ -66,23 +87,25 @@ sub build_import_methods {
 
         for my $package (@also)
         {
-            die "Circular reference in also parameter to MooseX::Exporter between $exporting_package and $package"
-                if $seen{$package};
+            die "Circular reference in also parameter to Moose::Exporter between $exporting_package and $package"
+                if $seen->{$package};
 
-            $seen{$package} = 1;
+            $seen->{$package} = 1;
         }
 
         return @also, map { _follow_also_real($_) } @also;
     }
 }
 
-sub _process_exports {
-    my $class    = shift;
-    my @packages = @_;
+sub _make_sub_exporter_params {
+    my $class             = shift;
+    my $packages          = shift;
+    my $export_recorder   = shift;
 
     my %exports;
+    my %is_removable;
 
-    for my $package (@packages) {
+    for my $package ( @{$packages} ) {
         my $args = $EXPORT_SPEC{$package}
             or die "The $package package does not use Moose::Exporter\n";
 
@@ -92,11 +115,15 @@ sub _process_exports {
                 \&{ $package . '::' . $name };
             };
 
+            my $fq_name = $package . '::' . $name;
+
             $exports{$name} = $class->_make_wrapped_sub(
-                $package,
-                $name,
-                $sub
+                $fq_name,
+                $sub,
+                $export_recorder,
             );
+
+            $is_removable{$name} = 1;
         }
 
         for my $name ( @{ $args->{as_is} } ) {
@@ -104,90 +131,183 @@ sub _process_exports {
 
             if ( ref $name ) {
                 $sub  = $name;
-                $name = ( Class::MOP::get_code_info($name) )[1];
+
+                # Even though Moose re-exports things from Carp &
+                # Scalar::Util, we don't want to remove those at
+                # unimport time, because the importing package may
+                # have imported them explicitly ala
+                #
+                # use Carp qw( confess );
+                #
+                # This is a hack. Since we can't know whether they
+                # really want to keep these subs or not, we err on the
+                # safe side and leave them in.
+                my $coderef_pkg;
+                ( $coderef_pkg, $name ) = Class::MOP::get_code_info($name);
+
+                $is_removable{$name} = $coderef_pkg eq $package ? 1 : 0;
             }
             else {
                 $sub = do {
                     no strict 'refs';
                     \&{ $package . '::' . $name };
                 };
+
+                $is_removable{$name} = 1;
             }
 
+            $export_recorder->{$sub} = 1;
+
             $exports{$name} = sub {$sub};
         }
     }
 
-    return \%exports;
+    return ( \%exports, \%is_removable );
 }
 
-{
-    # This variable gets closed over in each export _generator_. Then
-    # in the generator we grab the value and close over it _again_ in
-    # the real export, so it gets captured each time the generator
-    # runs.
-    #
-    # In the meantime, we arrange for the import method we generate to
-    # set this variable to the caller each time it is called.
-    #
-    # This is all a bit confusing, but it works.
-    my $CALLER;
-
-    sub _make_wrapped_sub {
-        my $class             = shift;
-        my $exporting_package = shift;
-        my $name              = shift;
-        my $sub               = shift;
-
-        # We need to set the package at import time, so that when
-        # package Foo imports has(), we capture "Foo" as the
-        # package. This lets other packages call Foo::has() and get
-        # the right package. This is done for backwards compatibility
-        # with existing production code, not because this is a good
-        # idea ;)
-        return sub {
-            my $caller = $CALLER;
-            Class::MOP::subname( $exporting_package . '::'
-                    . $name => sub { $sub->( $caller, @_ ) } );
-        };
-    }
+our $CALLER;
 
-    sub _make_import_sub {
-        my $class          = shift;
-        my $exporter       = shift;
+sub _make_wrapped_sub {
+    my $self            = shift;
+    my $fq_name         = shift;
+    my $sub             = shift;
+    my $export_recorder = shift;
 
-        return sub {
+    # We need to set the package at import time, so that when
+    # package Foo imports has(), we capture "Foo" as the
+    # package. This lets other packages call Foo::has() and get
+    # the right package. This is done for backwards compatibility
+    # with existing production code, not because this is a good
+    # idea ;)
+    return sub {
+        my $caller = $CALLER;
 
-            # It's important to leave @_ as-is for the benefit of
-            # Sub::Exporter.
-            my $class = $_[0];
+        my $wrapper = $self->_make_wrapper($caller, $sub, $fq_name);
 
-            $CALLER = Moose::Exporter::_get_caller(@_);
+        my $sub = Class::MOP::subname($fq_name => $wrapper);
 
-            # 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)
+        $export_recorder->{$sub} = 1;
 
-            strict->import;
-            warnings->import;
+        return $sub;
+    };
+}
 
-            # we should never export to main
-            if ( $CALLER eq 'main' ) {
-                warn
-                    qq{$class does not export its sugar to the 'main' package.\n};
-                return;
-            }
+sub _make_wrapper {
+    shift;
+    my $caller  = shift;
+    my $sub     = shift;
+    my $fq_name = shift;
 
-            if ( $class->can('init_meta') ) {
-                $class->init_meta(
-                    for_class => $CALLER,
-                );
-            }
+    return sub { $sub->($caller, @_) };
+}
 
-            goto $exporter;
-        };
-    }
+sub _make_import_sub {
+    shift;
+    my $exporting_package = shift;
+    my $exporter          = shift;
+    my $exports_from      = shift;
+    my $export_to_main    = shift;
+
+    return sub {
+
+        # I think we could use Sub::Exporter's collector feature
+        # to do this, but that would be rather gross, since that
+        # feature isn't really designed to return a value to the
+        # caller of the exporter sub.
+        #
+        # Also, this makes sure we preserve backwards compat for
+        # _get_caller, so it always sees the arguments in the
+        # expected order.
+        my $traits;
+        ( $traits, @_ ) = _strip_traits(@_);
+
+        # Normally we could look at $_[0], but in some weird cases
+        # (involving goto &Moose::import), $_[0] ends as something
+        # else (like Squirrel).
+        my $class = $exporting_package;
+
+        $CALLER = _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' && !$export_to_main ) {
+            warn
+                qq{$class does not export its sugar to the 'main' package.\n};
+            return;
+        }
+
+        my $did_init_meta;
+        for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) {
+            # init_meta can apply a role, which when loaded uses
+            # Moose::Exporter, which in turn sets $CALLER, so we need
+            # to protect against that.
+            local $CALLER = $CALLER;
+            $c->init_meta( for_class => $CALLER );
+            $did_init_meta = 1;
+        }
+
+        if ( $did_init_meta && @{$traits} ) {
+            # The traits will use Moose::Role, which in turn uses
+            # Moose::Exporter, which in turn sets $CALLER, so we need
+            # to protect against that.
+            local $CALLER = $CALLER;
+            _apply_meta_traits( $CALLER, $traits );
+        }
+        elsif ( @{$traits} ) {
+            Moose->throw_error(
+                "Cannot provide traits when $class does not have an init_meta() method"
+            );
+        }
+
+        goto $exporter;
+    };
+}
+
+
+sub _strip_traits {
+    my $idx = first_index { $_ eq '-traits' } @_;
+
+    return ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
+
+    my $traits = $_[ $idx + 1 ];
+
+    splice @_, $idx, 2;
+
+    $traits = [ $traits ] unless ref $traits;
+
+    return ( $traits, @_ );
+}
+
+sub _apply_meta_traits {
+    my ( $class, $traits ) = @_;
+
+    return unless @{$traits};
+
+    my $meta = $class->meta();
+
+    my $type = ( split /::/, ref $meta )[-1]
+        or Moose->throw_error(
+        'Cannot determine metaclass type for trait application . Meta isa '
+        . ref $meta );
+
+    my @resolved_traits
+        = map { Moose::Util::resolve_metatrait_alias( $type => $_ ) }
+        @$traits;
+
+    return unless @resolved_traits;
+
+    Moose::Util::MetaRole::apply_metaclass_roles(
+        for_class       => $class,
+        metaclass_roles => \@resolved_traits,
+    );
 }
 
 sub _get_caller {
@@ -203,20 +323,47 @@ sub _get_caller {
 }
 
 sub _make_unimport_sub {
-    my $class    = shift;
-    my $exported = shift;
+    shift;
+    my $exporting_package = shift;
+    my $exports           = shift;
+    my $is_removable      = shift;
+    my $export_recorder   = shift;
 
-    # [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.
     return sub {
-        @_ = ( 'namespace::clean', @{$exported} );
-
-        goto &namespace::clean::import;
+        my $caller = scalar caller();
+        Moose::Exporter->_remove_keywords(
+            $caller,
+            [ keys %{$exports} ],
+            $is_removable,
+            $export_recorder,
+        );
     };
 }
 
+sub _remove_keywords {
+    shift;
+    my $package          = shift;
+    my $keywords         = shift;
+    my $is_removable     = shift;
+    my $recorded_exports = shift;
+
+    no strict 'refs';
+
+    foreach my $name ( @{ $keywords } ) {
+        next unless $is_removable->{$name};
+
+        if ( defined &{ $package . '::' . $name } ) {
+            my $sub = \&{ $package . '::' . $name };
+
+            # make sure it is from us
+            next unless $recorded_exports->{$sub};
+
+            # and if it is from us, then undef the slot
+            delete ${ $package . '::' }{$name};
+        }
+    }
+}
+
 1;
 
 __END__
@@ -235,18 +382,27 @@ Moose::Exporter - make an import() and unimport() just like Moose.pm
   use Moose ();
   use Moose::Exporter;
 
-  Moose::Exporter->build_export_methods(
-      export         => [ 'sugar1', 'sugar2', \&Some::Random::thing ],
-      init_meta_args => { metaclass_class => 'MyApp::Meta::Class' ],
+  Moose::Exporter->setup_import_methods(
+      with_caller => [ 'has_rw', 'sugar2' ],
+      as_is       => [ 'sugar3', \&Some::Random::thing ],
+      also        => 'Moose',
   );
 
+  sub has_rw {
+      my ($caller, $name, %options) = @_;
+      Class::MOP::Class->initialize($caller)->add_attribute($name,
+          is => 'rw',
+          %options,
+      );
+  }
+
   # then later ...
   package MyApp::User;
 
   use MyApp::Moose;
 
   has 'name';
-  sugar1 'do your thing';
+  has_rw 'size';
   thing;
 
   no MyApp::Moose;
@@ -263,9 +419,9 @@ C<MooseX> module, as long as they all use C<Moose::Exporter>.
 
 =head1 METHODS
 
-This module provides exactly one public method:
+This module provides two public methods:
 
-=head2 Moose::Exporter->build_import_methods(...)
+=head2 Moose::Exporter->setup_import_methods(...)
 
 When you call this method, C<Moose::Exporter> build custom C<import>
 and C<unimport> methods for your module. The import method will export
@@ -293,12 +449,58 @@ as-is. You can identify a subroutine by reference, which is handy to
 re-export some other module's functions directly by reference
 (C<\&Some::Package::function>).
 
-=item * init_meta_args
+If you do export some other packages function, this function will
+never be removed by the C<unimport> method. The reason for this is we
+cannot know if the caller I<also> explicitly imported the sub
+themselves, and therefore wants to keep it.
 
-...
+=item * also => $name or \@names
+
+This is a list of modules which contain functions that the caller
+wants to export. These modules must also use C<Moose::Exporter>. The
+most common use case will be to export the functions from C<Moose.pm>.
+
+C<Moose::Exporter> also makes sure all these functions get removed
+when C<unimport> is called.
 
 =back
 
+=head2 Moose::Exporter->build_import_methods(...)
+
+Returns two code refs, one for import and one for unimport.
+
+Used by C<setup_import_methods>.
+
+=head1 IMPORTING AND init_meta
+
+If you want to set an alternative base object class or metaclass
+class, simply define an C<init_meta> method in your class. The
+C<import> method that C<Moose::Exporter> generates for you will call
+this method (if it exists). It will always pass the caller to this
+method via the C<for_class> parameter.
+
+Most of the time, your C<init_meta> method will probably just call C<<
+Moose->init_meta >> to do the real work:
+
+  sub init_meta {
+      shift; # our class name
+      return Moose->init_meta( @_, metaclass => 'My::Metaclass' );
+  }
+
+=head1 METACLASS TRAITS
+
+The C<import> method generated by C<Moose::Exporter> will allow the
+user of your module to specify metaclass traits in a C<-traits>
+parameter passed as part of the import:
+
+  use Moose -traits => 'My::Meta::Trait';
+
+  use Moose -traits => [ 'My::Meta::Trait', 'My::Other::Trait' ];
+
+These traits will be applied to the caller's metaclass
+instance. Providing traits for an exporting class that does not create
+a metaclass for the caller is an error.
+
 =head1 AUTHOR
 
 Dave Rolsky E<lt>autarch@urth.orgE<gt>