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