lib/Moose/Exporter.pm

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