lib/Mouse/Exporter.pm

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