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