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