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