lib/Exporter.pm

   1 package Mouse::Exporter;
   2 use strict;
   3 use warnings;
   4
   5 use Carp 'confess';
   6 use Scalar::Util qw(looks_like_number);
   7
   8 use Mouse::Util ();
   9
  10 my %SPEC;
  11
  12 sub setup_import_methods{
  13     my($class, %args) = @_;
  14
  15     my $exporting_package = $args{exporting_package} ||= caller();
  16
  17     my $spec = $SPEC{$exporting_package} = {};
  18
  19     # canonicalize args
  20     my @export_from = ($exporting_package);
  21     {
  22         my %seen  = ($exporting_package => 1);
  23         my @stack = ($exporting_package);
  24
  25         while(my $current = shift @stack){
  26             push @export_from, $current;
  27
  28             my $also = $args{also} or next;
  29             unshift @stack, grep{ ++$seen{$_} == 1 } @{ $also };
  30         }
  31     }
  32
  33     print "[@export_from]\n";
  34
  35     my $import    = sub{ _do_import   ($spec, @_) };
  36     my $unimport  = sub{ _do_unimport ($spec, @_) };
  37     my $init_meta = sub{ _do_init_meta($spec, @_) };
  38
  39     no strict 'refs';
  40
  41     *{$exporting_package . '::import'}    = $import;
  42     *{$exporting_package . '::unimport'}  = $unimport;
  43     *{$exporting_package . '::init_meta'} = $init_meta;
  44
  45     return;
  46 }
  47
  48 sub init_meta {
  49     shift;
  50     my %args = @_;
  51
  52     my $class = $args{for_class}
  53                     or confess("Cannot call init_meta without specifying a for_class");
  54     my $base_class = $args{base_class} || 'Mouse::Object';
  55     my $metaclass  = $args{metaclass}  || 'Mouse::Meta::Class';
  56
  57     confess("The Metaclass $metaclass must be a subclass of Mouse::Meta::Class.")
  58             unless $metaclass->isa('Mouse::Meta::Class');
  59
  60     # make a subtype for each Mouse class
  61     Mouse::Util::TypeConstraints::class_type($class)
  62         unless Mouse::Util::TypeConstraints::find_type_constraint($class);
  63
  64     my $meta = $metaclass->initialize($class);
  65
  66     $meta->add_method(meta => sub{
  67         return $metaclass->initialize(ref($_[0]) || $_[0]);
  68     });
  69
  70     $meta->superclasses($base_class)
  71         unless $meta->superclasses;
  72
  73     return $meta;
  74 }
  75
  76 sub _do_import {
  77     my($class, $spec, @args) = @_;
  78
  79     my $command;
  80
  81     my @exports;
  82     foreach my $arg(@args){
  83         if(ref $arg){ # e.g. use Mouse { into => $package };
  84             $command = $arg;
  85         }
  86         elsif($arg =~ s/^[-:]//){
  87             my $group = $spec->{group}{$arg} or confess(qq{group "$arg" is not exported by the $class module});
  88             push @exports, @{$group};
  89         }
  90         else{
  91             push @exports, $arg;
  92         }
  93     }
  94
  95     my $into = $command->{into} || caller(($command->{into_level} || 0) + 1);
  96
  97     strict->import;
  98     warnings->import;
  99
 100     if($into eq 'main' && !$spec->{_not_export_to_main}){
 101         warn qq{$class does not export its sugar to the 'main' package.\n};
 102         return;
 103     }
 104
 105     $class->init_meta(
 106         for_class  => $into,
 107     );
 108
 109     my $exports_ref = @exports ? \@exports : $spec->{default};
 110
 111     foreach my $keyword(@{$exports_ref}){
 112         no strict 'refs';
 113         *{$into.'::'.$keyword} = $spec->{exports}{$keyword}
 114             or confess(qq{"$keyword" is not exported by the $class module});
 115     }
 116     return;
 117 }
 118
 119 sub _do_unimport {
 120     my($class, $spec) = @_;
 121
 122     my $caller = caller;
 123
 124     my $stash = do{
 125         no strict 'refs';
 126         \%{$caller . '::'}
 127     };
 128
 129     for my $keyword (@{ $spec->{exports} }) {
 130         my $code;
 131         if(exists $spec->{is_removable}{$keyword}
 132             && ($code = $caller->can($keyword))
 133             && (Mouse::Util::get_code_info($code))[0] eq __PACKAGE__){
 134
 135             delete $stash->{$keyword};
 136         }
 137     }
 138 }
 139
 140 1;
 141
 142 __END__
 143
 144 =head1 NAME
 145
 146 Mouse - The Mouse Exporter
 147
 148 =head1 SYNOPSIS
 149
 150     package MouseX::Foo;
 151     use Mouse::Exporter;
 152
 153     Mouse::Exporter->setup_import_methods(
 154
 155     );
 156
 157 =head1 DESCRIPTION
 158
 159
 160 =head1 SEE ALSO
 161
 162 L<Moose::Exporter>
 163
 164 =head1 AUTHORS
 165
 166 Goro Fuji (gfx) C<< <gfuji at cpan.org> >>
 167
 168 =cut
 169