lib/Moose/Exporter.pm

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