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