lib/Moose/Exporter.pm

   1 package Moose::Exporter;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Class::MOP;
   7 use List::MoreUtils qw( uniq );
   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_from = $class->_follow_also( $exporting_package );
  22
  23     my $exports
  24         = $class->_process_exports( $exporting_package, @exports_from );
  25
  26     my $exporter = Sub::Exporter::build_exporter(
  27         {
  28             exports => $exports,
  29             groups  => { default => [':all'] }
  30         }
  31     );
  32
  33     # $args{_export_to_main} exists for backwards compat, because
  34     # Moose::Util::TypeConstraints did export to main (unlike Moose &
  35     # Moose::Role).
  36     my $import = $class->_make_import_sub( $exporter, \@exports_from, $args{_export_to_main} );
  37
  38     my $unimport = $class->_make_unimport_sub( \@exports_from, [ keys %{$exports} ] );
  39
  40     no strict 'refs';
  41     *{ $exporting_package . '::import' }   = $import;
  42     *{ $exporting_package . '::unimport' } = $unimport;
  43 }
  44
  45 {
  46     my %seen;
  47
  48     sub _follow_also {
  49         my $class             = shift;
  50         my $exporting_package = shift;
  51
  52         %seen = ( $exporting_package => 1 );
  53
  54         return uniq( _follow_also_real($exporting_package) );
  55     }
  56
  57     sub _follow_also_real {
  58         my $exporting_package = shift;
  59
  60         die "Package in also ($exporting_package) does not seem to use MooseX::Exporter"
  61             unless exists $EXPORT_SPEC{$exporting_package};
  62
  63         my $also = $EXPORT_SPEC{$exporting_package}{also};
  64
  65         return unless defined $also;
  66
  67         my @also = ref $also ? @{$also} : $also;
  68
  69         for my $package (@also)
  70         {
  71             die "Circular reference in also parameter to MooseX::Exporter between $exporting_package and $package"
  72                 if $seen{$package};
  73
  74             $seen{$package} = 1;
  75         }
  76
  77         return @also, map { _follow_also_real($_) } @also;
  78     }
  79 }
  80
  81 sub _process_exports {
  82     my $class    = shift;
  83     my @packages = @_;
  84
  85     my %exports;
  86
  87     for my $package (@packages) {
  88         my $args = $EXPORT_SPEC{$package}
  89             or die "The $package package does not use Moose::Exporter\n";
  90
  91         for my $name ( @{ $args->{with_caller} } ) {
  92             my $sub = do {
  93                 no strict 'refs';
  94                 \&{ $package . '::' . $name };
  95             };
  96
  97             $exports{$name} = $class->_make_wrapped_sub(
  98                 $package,
  99                 $name,
 100                 $sub
 101             );
 102         }
 103
 104         for my $name ( @{ $args->{as_is} } ) {
 105             my $sub;
 106
 107             if ( ref $name ) {
 108                 $sub  = $name;
 109                 $name = ( Class::MOP::get_code_info($name) )[1];
 110             }
 111             else {
 112                 $sub = do {
 113                     no strict 'refs';
 114                     \&{ $package . '::' . $name };
 115                 };
 116             }
 117
 118             $exports{$name} = sub {$sub};
 119         }
 120     }
 121
 122     return \%exports;
 123 }
 124
 125 {
 126     # This variable gets closed over in each export _generator_. Then
 127     # in the generator we grab the value and close over it _again_ in
 128     # the real export, so it gets captured each time the generator
 129     # runs.
 130     #
 131     # In the meantime, we arrange for the import method we generate to
 132     # set this variable to the caller each time it is called.
 133     #
 134     # This is all a bit confusing, but it works.
 135     my $CALLER;
 136
 137     sub _make_wrapped_sub {
 138         my $class             = shift;
 139         my $exporting_package = shift;
 140         my $name              = shift;
 141         my $sub               = shift;
 142
 143         # We need to set the package at import time, so that when
 144         # package Foo imports has(), we capture "Foo" as the
 145         # package. This lets other packages call Foo::has() and get
 146         # the right package. This is done for backwards compatibility
 147         # with existing production code, not because this is a good
 148         # idea ;)
 149         return sub {
 150             my $caller = $CALLER;
 151             Class::MOP::subname( $exporting_package . '::'
 152                     . $name => sub { $sub->( $caller, @_ ) } );
 153         };
 154     }
 155
 156     sub _make_import_sub {
 157         shift;
 158         my $exporter       = shift;
 159         my $exports_from   = shift;
 160         my $export_to_main = shift;
 161
 162         return sub {
 163
 164             # It's important to leave @_ as-is for the benefit of
 165             # Sub::Exporter.
 166             my $class = $_[0];
 167
 168             $CALLER = Moose::Exporter::_get_caller(@_);
 169
 170             # this works because both pragmas set $^H (see perldoc
 171             # perlvar) which affects the current compilation -
 172             # i.e. the file who use'd us - which is why we don't need
 173             # to do anything special to make it affect that file
 174             # rather than this one (which is already compiled)
 175
 176             strict->import;
 177             warnings->import;
 178
 179             # we should never export to main
 180             if ( $CALLER eq 'main' && ! $export_to_main ) {
 181                 warn
 182                     qq{$class does not export its sugar to the 'main' package.\n};
 183                 return;
 184             }
 185
 186             for my $c (grep { $_->can('init_meta') } $class, @{$exports_from} ) {
 187
 188                 $c->init_meta( for_class => $CALLER );
 189             }
 190
 191             goto $exporter;
 192         };
 193     }
 194 }
 195
 196 sub _get_caller {
 197     # 1 extra level because it's called by import so there's a layer
 198     # of indirection
 199     my $offset = 1;
 200
 201     return
 202           ( ref $_[1] && defined $_[1]->{into} ) ? $_[1]->{into}
 203         : ( ref $_[1] && defined $_[1]->{into_level} )
 204         ? caller( $offset + $_[1]->{into_level} )
 205         : caller($offset);
 206 }
 207
 208 sub _make_unimport_sub {
 209     shift;
 210     my $sources  = shift;
 211     my $keywords = shift;
 212
 213     return sub {
 214         my $class  = shift;
 215         my $caller = scalar caller();
 216         Moose::Exporter->_remove_keywords(
 217             $caller,
 218             [ $class, @{$sources} ],
 219             $keywords
 220         );
 221     };
 222 }
 223
 224 sub _remove_keywords {
 225     shift;
 226     my $package  = shift;
 227     my $sources  = shift;
 228     my $keywords = shift;
 229
 230     my %sources = map { $_ => 1 } @{$sources};
 231
 232     no strict 'refs';
 233
 234     # loop through the keywords ...
 235     foreach my $name ( @{$keywords} ) {
 236
 237         # if we find one ...
 238         if ( defined &{ $package . '::' . $name } ) {
 239             my $keyword = \&{ $package . '::' . $name };
 240
 241             # make sure it is from us
 242             my ($pkg_name) = Class::MOP::get_code_info($keyword);
 243             next unless $sources{$pkg_name};
 244
 245             # and if it is from us, then undef the slot
 246             delete ${ $package . '::' }{$name};
 247         }
 248     }
 249 }
 250
 251 1;
 252
 253 __END__
 254
 255 =head1 NAME
 256
 257 Moose::Exporter - make an import() and unimport() just like Moose.pm
 258
 259 =head1 SYNOPSIS
 260
 261   package MyApp::Moose;
 262
 263   use strict;
 264   use warnings;
 265
 266   use Moose ();
 267   use Moose::Exporter;
 268
 269   Moose::Exporter->build_export_methods(
 270       export         => [ 'sugar1', 'sugar2', \&Some::Random::thing ],
 271       init_meta_args => { metaclass_class => 'MyApp::Meta::Class' ],
 272   );
 273
 274   # then later ...
 275   package MyApp::User;
 276
 277   use MyApp::Moose;
 278
 279   has 'name';
 280   sugar1 'do your thing';
 281   thing;
 282
 283   no MyApp::Moose;
 284
 285 =head1 DESCRIPTION
 286
 287 This module encapsulates the logic to export sugar functions like
 288 C<Moose.pm>. It does this by building custom C<import> and C<unimport>
 289 methods for your module, based on a spec your provide.
 290
 291 It also lets your "stack" Moose-alike modules so you can export
 292 Moose's sugar as well as your own, along with sugar from any random
 293 C<MooseX> module, as long as they all use C<Moose::Exporter>.
 294
 295 =head1 METHODS
 296
 297 This module provides exactly one public method:
 298
 299 =head2 Moose::Exporter->build_import_methods(...)
 300
 301 When you call this method, C<Moose::Exporter> build custom C<import>
 302 and C<unimport> methods for your module. The import method will export
 303 the functions you specify, and you can also tell it to export
 304 functions exported by some other module (like C<Moose.pm>).
 305
 306 The C<unimport> method cleans the callers namespace of all the
 307 exported functions.
 308
 309 This method accepts the following parameters:
 310
 311 =over 4
 312
 313 =item * with_caller => [ ... ]
 314
 315 This a list of function I<names only> to be exported wrapped and then
 316 exported. The wrapper will pass the name of the calling package as the
 317 first argument to the function. Many sugar functions need to know
 318 their caller so they can get the calling package's metaclass object.
 319
 320 =item * as_is => [ ... ]
 321
 322 This a list of function names or sub references to be exported
 323 as-is. You can identify a subroutine by reference, which is handy to
 324 re-export some other module's functions directly by reference
 325 (C<\&Some::Package::function>).
 326
 327 =item * also => $name or \@names
 328
 329 This is a list of modules which contain functions that the caller
 330 wants to export. These modules must also use C<Moose::Exporter>. The
 331 most common use case will be to export the functions from C<Moose.pm>.
 332
 333 C<Moose::Exporter> also makes sure all these functions get removed
 334 when C<unimport> is called.
 335
 336 =back
 337
 338 =head1 IMPORTING AND init_meta
 339
 340 If you want to set an alternative base object class or metaclass
 341 class, simply define an C<init_meta> method in your class. The
 342 C<import> method that C<Moose::Exporter> generates for you will call
 343 this method (if it exists). It will always pass the caller to this
 344 method via the C<for_class> parameter.
 345
 346 Most of the time, your C<init_meta> method will probably just call C<<
 347 Moose->init_meta >> to do the real work:
 348
 349   sub init_meta {
 350       shift; # our class name
 351       return Moose->init_meta( @_, metaclass => 'My::Metaclass' );
 352   }
 353
 354 =head1 AUTHOR
 355
 356 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 357
 358 This is largely a reworking of code in Moose.pm originally written by
 359 Stevan Little and others.
 360
 361 =head1 COPYRIGHT AND LICENSE
 362
 363 Copyright 2008 by Infinity Interactive, Inc.
 364
 365 L<http://www.iinteractive.com>
 366
 367 This library is free software; you can redistribute it and/or modify
 368 it under the same terms as Perl itself.
 369
 370 =cut