lib/Mouse/Exporter.pm

   1 package Mouse::Exporter;
   2 use strict;
   3 use warnings;
   4
   5 use Carp qw(confess);
   6
   7 use Mouse::Util qw(get_code_info not_supported);
   8
   9 my %SPEC;
  10
  11 my $strict_bits = strict::bits(qw(subs refs vars));
  12
  13 sub setup_import_methods{
  14     my($class, %args) = @_;
  15
  16     my $exporting_package = $args{exporting_package} ||= caller();
  17
  18     $SPEC{$exporting_package} = \%args;
  19
  20     # canonicalize args
  21     my @export_from;
  22     if($args{also}){
  23         my %seen;
  24         my @stack = ($exporting_package);
  25
  26         while(my $current = shift @stack){
  27             push @export_from, $current;
  28
  29             my $also = $SPEC{$current}{also} or next;
  30             push @stack, grep{ !$seen{$_}++ } @{ $also };
  31         }
  32     }
  33     else{
  34         @export_from = ($exporting_package);
  35     }
  36
  37     {
  38         my %exports;
  39         my @removables;
  40         my @all;
  41
  42         my @init_meta_methods;
  43
  44         foreach my $package(@export_from){
  45             my $spec = $SPEC{$package} or next;
  46
  47             if(my $as_is = $spec->{as_is}){
  48                 foreach my $thingy (@{$as_is}){
  49                     my($code_package, $code_name, $code);
  50
  51                     if(ref($thingy)){
  52                         $code = $thingy;
  53                         ($code_package, $code_name) = get_code_info($code);
  54                     }
  55                     else{
  56                         no strict 'refs';
  57                         $code_package = $package;
  58                         $code_name    = $thingy;
  59                         $code         = \&{ $code_package . '::' . $code_name };
  60                    }
  61
  62                     push @all, $code_name;
  63                     $exports{$code_name} = $code;
  64                     if($code_package eq $package){
  65                         push @removables, $code_name;
  66                     }
  67                 }
  68             }
  69
  70             if(my $init_meta = $package->can('init_meta')){
  71                 if(!grep{ $_ == $init_meta } @init_meta_methods){
  72                     unshift @init_meta_methods, $init_meta;
  73                 }
  74             }
  75         }
  76         $args{EXPORTS}    = \%exports;
  77         $args{REMOVABLES} = \@removables;
  78
  79         $args{group}{all}     ||= \@all;
  80
  81         if(my $default_list = $args{group}{default}){
  82             my %default;
  83             foreach my $keyword(@{$default_list}){
  84                 $default{$keyword} = $exports{$keyword}
  85                     || confess(qq{The $exporting_package package does not export "$keyword"});
  86             }
  87             $args{DEFAULT} = \%default;
  88         }
  89         else{
  90             $args{group}{default} ||= \@all;
  91             $args{DEFAULT}          = $args{EXPORTS};
  92         }
  93
  94         if(@init_meta_methods){
  95             $args{INIT_META} = \@init_meta_methods;
  96         }
  97     }
  98
  99     no strict 'refs';
 100
 101     *{$exporting_package . '::import'}    = \&do_import;
 102     *{$exporting_package . '::unimport'}  = \&do_unimport;
 103
 104     return;
 105 }
 106
 107
 108 # the entity of general import()
 109 sub do_import {
 110     my($package, @args) = @_;
 111
 112     my $spec = $SPEC{$package}
 113         || confess("The package $package package does not use Mouse::Exporter");
 114
 115     my $into = _get_caller_package(ref($args[0]) ? shift @args : undef);
 116
 117     my @exports;
 118     foreach my $arg(@args){
 119         if($arg =~ s/^-//){
 120             not_supported "-$arg";
 121         }
 122         elsif($arg =~ s/^://){
 123             my $group = $spec->{group}{$arg}
 124                 || confess(qq{The $package package does not export the group "$arg"});
 125             push @exports, @{$group};
 126         }
 127         else{
 128             push @exports, $arg;
 129         }
 130     }
 131
 132     $^H              |= $strict_bits;         # strict->import;
 133     ${^WARNING_BITS}  = $warnings::Bits{all}; # warnings->import;
 134
 135     if($into eq 'main' && !$spec->{_not_export_to_main}){
 136         warn qq{$package does not export its sugar to the 'main' package.\n};
 137         return;
 138     }
 139
 140     if($spec->{INIT_META}){
 141         foreach my $init_meta(@{$spec->{INIT_META}}){
 142             $into->$init_meta(for_class => $into);
 143         }
 144
 145         # _apply_meta_traits($into); # TODO
 146     }
 147
 148     if(@exports){
 149         foreach my $keyword(@exports){
 150             no strict 'refs';
 151             *{$into.'::'.$keyword} = $spec->{EXPORTS}{$keyword}
 152                 || confess(qq{The $package package does not export "$keyword"});
 153         }
 154     }
 155     else{
 156         my $default = $spec->{DEFAULT};
 157         while(my($keyword, $code) = each %{$default}){
 158             no strict 'refs';
 159             *{$into.'::'.$keyword} = $code;
 160         }
 161     }
 162     return;
 163 }
 164
 165 # the entity of general unimport()
 166 sub do_unimport {
 167     my($package, $arg) = @_;
 168
 169     my $spec = $SPEC{$package}
 170         || confess("The package $package does not use Mouse::Exporter");
 171
 172     my $from = _get_caller_package($arg);
 173
 174     my $stash = do{
 175         no strict 'refs';
 176         \%{$from . '::'}
 177     };
 178
 179     for my $keyword (@{ $spec->{REMOVABLES} }) {
 180         my $gv = \$stash->{$keyword};
 181         if(ref($gv) eq 'GLOB' && *{$gv}{CODE} == $spec->{EXPORTS}{$keyword}){ # make sure it is from us
 182             delete $stash->{$keyword};
 183         }
 184     }
 185     return;
 186 }
 187
 188 sub _get_caller_package {
 189     my($arg) = @_;
 190
 191     # 2 extra level because it's called by import so there's a layer\r
 192     # of indirection\r
 193     my $offset = 1;\r
 194
 195     if(ref $arg){
 196         return defined($arg->{into})       ? $arg->{into}
 197              : defined($arg->{into_level}) ? scalar caller($offset + $arg->{into_level})
 198              :                               scalar caller($offset);
 199     }
 200     else{
 201         return scalar caller($offset);
 202     }
 203 }
 204
 205 1;
 206
 207 __END__
 208
 209 =head1 NAME
 210
 211 Mouse - The Mouse Exporter
 212
 213 =head1 SYNOPSIS
 214
 215     package MouseX::Foo;
 216     use Mouse::Exporter;
 217
 218     Mouse::Exporter->setup_import_methods(
 219
 220     );
 221
 222 =head1 DESCRIPTION
 223
 224
 225 =head1 SEE ALSO
 226
 227 L<Moose::Exporter>
 228
 229 =cut