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