lib/Moose/Exporter.pm

   1 package Moose::Exporter;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Class::MOP;
   7 use Sub::Exporter;
   8
   9
  10 sub get_caller{
  11     # 1 extra level because it's called by import so there's a layer of indirection
  12     my $offset = 1;
  13
  14     return
  15         (ref $_[1] && defined $_[1]->{into})
  16             ? $_[1]->{into}
  17                 : (ref $_[1] && defined $_[1]->{into_level})
  18                     ? caller($offset + $_[1]->{into_level})
  19                     : caller($offset);
  20 }
  21
  22 sub build_import_methods {
  23     my $class = shift;
  24     my %args  = @_;
  25
  26     my $exporting_package = caller();
  27
  28     my $exporter = $class->_build_exporter( exporting_package => $exporting_package, %args );
  29
  30     my $also = $args{also};
  31
  32     my $import = sub {
  33         my $caller = Moose::Exporter->get_caller(@_);
  34
  35         # this works because both pragmas set $^H (see perldoc perlvar)
  36         # which affects the current compilation - i.e. the file who use'd
  37         # us - which is why we don't need to do anything special to make
  38         # it affect that file rather than this one (which is already compiled)
  39
  40         strict->import;
  41         warnings->import;
  42
  43         # we should never export to main
  44         if ( $caller eq 'main' ) {
  45             warn
  46                 qq{$exporting_package does not export its sugar to the 'main' package.\n};
  47             return;
  48         }
  49
  50         $also->($caller) if $also;
  51
  52         goto $exporter;
  53     };
  54
  55     my $unimport = sub {
  56         my $caller = Moose::Exporter->get_caller(@_);
  57
  58         Moose::Exporter->remove_keywords(
  59             source => $exporting_package,
  60             from   => $caller,
  61         );
  62     };
  63
  64     no strict 'refs';
  65     *{ $exporting_package . '::import' } = $import;
  66     *{ $exporting_package . '::unimport' } = $unimport;
  67 }
  68
  69 my %EXPORTED;
  70 sub _build_exporter {
  71     my $class = shift;
  72     my %args  = @_;
  73
  74     my $exporting_package = $args{exporting_package};
  75
  76     my %exports;
  77     for my $name ( @{ $args{with_caller} } ) {
  78         my $sub = do { no strict 'refs'; \&{ $exporting_package . '::' . $name } };
  79
  80         my $wrapped = Class::MOP::subname(
  81             $exporting_package . '::' . $name => sub { $sub->( scalar caller(), @_ ) } );
  82
  83         $exports{$name} = sub { $wrapped };
  84
  85         push @{ $EXPORTED{$exporting_package} }, $name;
  86     }
  87
  88     for my $name ( @{ $args{as_is} } ) {
  89         my $sub;
  90
  91         if ( ref $name ) {
  92             $sub  = $name;
  93             $name = ( Class::MOP::get_code_info($name) )[1];
  94         }
  95         else {
  96             $sub = do { no strict 'refs'; \&{ $exporting_package . '::' . $name } };
  97
  98             push @{ $EXPORTED{$exporting_package} }, $name;
  99         }
 100
 101         $exports{$name} = sub { $sub };
 102     }
 103
 104     return Sub::Exporter::build_exporter(
 105         {
 106             exports => \%exports,
 107             groups  => { default => [':all'] }
 108         }
 109     );
 110 }
 111
 112 sub remove_keywords {
 113     my $class = shift;
 114     my %args  = @_;
 115
 116     no strict 'refs';
 117
 118     for my $name ( @{ $EXPORTED{ $args{source} } } ) {
 119         if ( defined &{ $args{from} . '::' . $name } ) {
 120             my $keyword = \&{ $args{from} . '::' . $name };
 121
 122             # make sure it is from us
 123             my ($pkg_name) = Class::MOP::get_code_info($keyword);
 124             next if $pkg_name ne $args{source};
 125
 126             # and if it is from us, then undef the slot
 127             delete ${ $args{from} . '::' }{$name};
 128         }
 129     }
 130 }
 131
 132 1;