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 my %EXPORTED;
  23 sub build_exporter {
  24     my $class = shift;
  25     my %args  = @_;
  26
  27     my $exporting_pkg = caller();
  28
  29     my %exports;
  30     for my $name ( @{ $args{with_caller} } ) {
  31         my $sub = do { no strict 'refs'; \&{ $exporting_pkg . '::' . $name } };
  32
  33         my $wrapped = Class::MOP::subname(
  34             $exporting_pkg . '::' . $name => sub { $sub->( scalar caller(), @_ ) } );
  35
  36         $exports{$name} = sub { $wrapped };
  37
  38         push @{ $EXPORTED{$exporting_pkg} }, $name;
  39     }
  40
  41     for my $name ( @{ $args{as_is} } ) {
  42         my $sub;
  43
  44         if ( ref $name ) {
  45             $sub  = $name;
  46             $name = ( Class::MOP::get_code_info($name) )[1];
  47         }
  48         else {
  49             $sub = do { no strict 'refs'; \&{ $exporting_pkg . '::' . $name } };
  50
  51             push @{ $EXPORTED{$exporting_pkg} }, $name;
  52         }
  53
  54         $exports{$name} = sub { $sub };
  55     }
  56
  57     return Sub::Exporter::build_exporter(
  58         {
  59             exports => \%exports,
  60             groups  => { default => [':all'] }
  61         }
  62     );
  63 }
  64
  65 sub remove_keywords {
  66     my $class = shift;
  67     my %args  = @_;
  68
  69     no strict 'refs';
  70
  71     for my $name ( @{ $EXPORTED{ $args{source} } } ) {
  72         if ( defined &{ $args{from} . '::' . $name } ) {
  73             my $keyword = \&{ $args{from} . '::' . $name };
  74
  75             # make sure it is from us
  76             my ($pkg_name) = Class::MOP::get_code_info($keyword);
  77             next if $pkg_name ne $args{source};
  78
  79             # and if it is from us, then undef the slot
  80             delete ${ $args{from} . '::' }{$name};
  81         }
  82     }
  83 }
  84
  85 1;