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