lib/Moose/Exporter.pm

   1 package Moose::Exporter;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Class::MOP;
   7 use namespace::clean 0.08 ();
   8 use Sub::Exporter;
   9
  10
  11 my %EXPORT_SPEC;
  12
  13 sub build_import_methods {
  14     my $class = shift;
  15     my %args  = @_;
  16
  17     my $exporting_package = caller();
  18
  19     $EXPORT_SPEC{$exporting_package} = \%args;
  20
  21     my ( $exporter, $exported ) = $class->_build_exporter(
  22         exporting_package => $exporting_package,
  23         %args
  24     );
  25
  26     my $import = $class->_make_import_sub(
  27         $exporting_package, $args{init_meta_args},
  28         $exporter
  29     );
  30
  31     my $unimport = $class->_make_unimport_sub($exported);
  32
  33     no strict 'refs';
  34     *{ $exporting_package . '::import' }   = $import;
  35     *{ $exporting_package . '::unimport' } = $unimport;
  36 }
  37
  38 my %EXPORTED;
  39 sub _build_exporter {
  40     my $class = shift;
  41     my %args  = @_;
  42
  43     my $exporting_package = $args{exporting_package};
  44
  45     my @exported_names;
  46     my %exports;
  47     for my $name ( @{ $args{with_caller} } ) {
  48         my $sub = do { no strict 'refs'; \&{ $exporting_package . '::' . $name } };
  49
  50         # We need to set the package at import time, so that when
  51         # package Foo imports has(), we capture "Foo" as the
  52         # package. This lets other packages call Foo::has() and get
  53         # the right package. This is done for backwards compatibility
  54         # with existing production code, not because this is a good
  55         # idea ;)
  56         $exports{$name} = sub {
  57             my $caller;
  58
  59             my $x = 0;
  60             do
  61             {
  62                 $caller = scalar caller($x++)
  63             }
  64             while ( $caller eq 'Sub::Exporter' );
  65
  66             Class::MOP::subname( $exporting_package . '::'
  67                     . $name => sub { $sub->( $caller, @_ ) } );
  68         };
  69
  70         push @exported_names, $name;
  71     }
  72
  73     for my $name ( @{ $args{as_is} } ) {
  74         my $sub;
  75
  76         if ( ref $name ) {
  77             $sub  = $name;
  78             $name = ( Class::MOP::get_code_info($name) )[1];
  79         }
  80         else {
  81             $sub = do { no strict 'refs'; \&{ $exporting_package . '::' . $name } };
  82
  83             push @exported_names, $name;
  84         }
  85
  86         $exports{$name} = sub { $sub };
  87     }
  88
  89     my $exporter = Sub::Exporter::build_exporter(
  90         {
  91             exports => \%exports,
  92             groups  => { default => [':all'] }
  93         }
  94     );
  95
  96     return $exporter, \@exported_names;
  97 }
  98
  99 sub _make_import_sub {
 100     my $class             = shift;
 101     my $exporting_package = shift;
 102     my $init_meta_args    = shift;
 103     my $exporter          = shift;
 104
 105     return sub {
 106         my $caller = Moose::Exporter->_get_caller(@_);
 107
 108         # this works because both pragmas set $^H (see perldoc perlvar)
 109         # which affects the current compilation - i.e. the file who use'd
 110         # us - which is why we don't need to do anything special to make
 111         # it affect that file rather than this one (which is already compiled)
 112
 113         strict->import;
 114         warnings->import;
 115
 116         # we should never export to main
 117         if ( $caller eq 'main' ) {
 118             warn
 119                 qq{$exporting_package does not export its sugar to the 'main' package.\n};
 120             return;
 121         }
 122
 123         if ( $exporting_package->can('_init_meta') ) {
 124             $exporting_package->_init_meta(
 125                 for_class => $caller,
 126                 %{ $init_meta_args || {} }
 127             );
 128         }
 129
 130         goto $exporter;
 131     };
 132 }
 133
 134 sub _get_caller {
 135     # 1 extra level because it's called by import so there's a layer
 136     # of indirection
 137     my $offset = 1;
 138
 139     return
 140           ( ref $_[1] && defined $_[1]->{into} ) ? $_[1]->{into}
 141         : ( ref $_[1] && defined $_[1]->{into_level} )
 142         ? caller( $offset + $_[1]->{into_level} )
 143         : caller($offset);
 144 }
 145
 146 sub _make_unimport_sub {
 147     my $class    = shift;
 148     my $exported = shift;
 149
 150     # [12:24]  <mst> yes. that's horrible. I know. but it should work.
 151     #
 152     # This will hopefully be replaced in the future once
 153     # namespace::clean has an API for it.
 154     return sub {
 155         @_ = ( 'namespace::clean', @{$exported} );
 156
 157         goto &namespace::clean::import;
 158     };
 159 }
 160
 161 1;
 162
 163 __END__
 164
 165 =head1 NAME
 166
 167 Moose::Exporter - make an import() and unimport() just like Moose.pm
 168
 169 =head1 SYNOPSIS
 170
 171   package MyApp::Moose;
 172
 173   use strict;
 174   use warnings;
 175
 176   use Moose ();
 177   use Moose::Exporter;
 178
 179   Moose::Exporter->build_export_methods(
 180       export         => [ 'sugar1', 'sugar2', \&Some::Random::thing ],
 181       init_meta_args => { metaclass_class => 'MyApp::Meta::Class' ],
 182   );
 183
 184   # then later ...
 185   package MyApp::User;
 186
 187   use MyApp::Moose;
 188
 189   has 'name';
 190   sugar1 'do your thing';
 191   thing;
 192
 193   no MyApp::Moose;
 194
 195 =head1 DESCRIPTION
 196
 197 This module encapsulates the logic to export sugar functions like
 198 C<Moose.pm>. It does this by building custom C<import> and C<unimport>
 199 methods for your module, based on a spec your provide.
 200
 201 It also lets your "stack" Moose-alike modules so you can export
 202 Moose's sugar as well as your own, along with sugar from any random
 203 C<MooseX> module, as long as they all use C<Moose::Exporter>.
 204
 205 =head1 METHODS
 206
 207 This module provides exactly one public method:
 208
 209 =head2 Moose::Exporter->build_import_methods(...)
 210
 211 When you call this method, C<Moose::Exporter> build custom C<import>
 212 and C<unimport> methods for your module. The import method will export
 213 the functions you specify, and you can also tell it to export
 214 functions exported by some other module (like C<Moose.pm>).
 215
 216 The C<unimport> method cleans the callers namespace of all the
 217 exported functions.
 218
 219 This method accepts the following parameters:
 220
 221 =over 4
 222
 223 =item * with_caller => [ ... ]
 224
 225 This a list of function I<names only> to be exported wrapped and then
 226 exported. The wrapper will pass the name of the calling package as the
 227 first argument to the function. Many sugar functions need to know
 228 their caller so they can get the calling package's metaclass object.
 229
 230 =item * as_is => [ ... ]
 231
 232 This a list of function names or sub references to be exported
 233 as-is. You can identify a subroutine by reference, which is handy to
 234 re-export some other module's functions directly by reference
 235 (C<\&Some::Package::function>).
 236
 237 =item * init_meta_args
 238
 239 ...
 240
 241 =back
 242
 243 =head1 AUTHOR
 244
 245 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 246
 247 This is largely a reworking of code in Moose.pm originally written by
 248 Stevan Little and others.
 249
 250 =head1 COPYRIGHT AND LICENSE
 251
 252 Copyright 2008 by Infinity Interactive, Inc.
 253
 254 L<http://www.iinteractive.com>
 255
 256 This library is free software; you can redistribute it and/or modify
 257 it under the same terms as Perl itself.
 258
 259 =cut