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