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