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 {
 165     # This variable gets closed over in each export _generator_. Then
 166     # in the generator we grab the value and close over it _again_ in
 167     # the real export, so it gets captured each time the generator
 168     # runs.
 169     #
 170     # In the meantime, we arrange for the import method we generate to
 171     # set this variable to the caller each time it is called.
 172     #
 173     # This is all a bit confusing, but it works.
 174     my $CALLER;
 175
 176     sub _make_wrapped_sub {
 177         shift;
 178         my $fq_name         = shift;
 179         my $sub             = shift;
 180         my $export_recorder = shift;
 181
 182
 183         # We need to set the package at import time, so that when
 184         # package Foo imports has(), we capture "Foo" as the
 185         # package. This lets other packages call Foo::has() and get
 186         # the right package. This is done for backwards compatibility
 187         # with existing production code, not because this is a good
 188         # idea ;)
 189         return sub {
 190             my $caller = $CALLER;
 191
 192             my $sub = Class::MOP::subname( $fq_name => sub { $sub->( $caller, @_ ) } );
 193
 194             $export_recorder->{$sub} = 1;
 195
 196             return $sub;
 197         };
 198     }
 199
 200     sub _make_import_sub {
 201         shift;
 202         my $exporting_package = shift;
 203         my $exporter          = shift;
 204         my $exports_from      = shift;
 205         my $export_to_main    = shift;
 206
 207         return sub {
 208             # I think we could use Sub::Exporter's collector feature
 209             # to do this, but that would be rather gross, since that
 210             # feature isn't really designed to return a value to the
 211             # caller of the exporter sub.
 212             #
 213             # Also, this makes sure we preserve backwards compat for
 214             # _get_caller, so it always sees the arguments in the
 215             # expected order.
 216             my $traits;
 217             ($traits, @_) = Moose::Exporter::_strip_traits(@_);
 218
 219             # Normally we could look at $_[0], but in some weird cases
 220             # (involving goto &Moose::import), $_[0] ends as something
 221             # else (like Squirrel).
 222             my $class = $exporting_package;
 223
 224             $CALLER = Moose::Exporter::_get_caller(@_);
 225
 226             # this works because both pragmas set $^H (see perldoc
 227             # perlvar) which affects the current compilation -
 228             # i.e. the file who use'd us - which is why we don't need
 229             # to do anything special to make it affect that file
 230             # rather than this one (which is already compiled)
 231
 232             strict->import;
 233             warnings->import;
 234
 235             # we should never export to main
 236             if ( $CALLER eq 'main' && ! $export_to_main ) {
 237                 warn
 238                     qq{$class does not export its sugar to the 'main' package.\n};
 239                 return;
 240             }
 241
 242             my $did_init_meta;
 243             for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) {
 244
 245                 $c->init_meta( for_class => $CALLER );
 246                 $did_init_meta = 1;
 247             }
 248
 249             if ( $did_init_meta && @{$traits} ) {
 250                 _apply_meta_traits( $CALLER, $traits );
 251             }
 252             elsif ( @{$traits} ) {
 253                 Moose->throw_error("Cannot provide traits when $class does not have an init_meta() method");
 254             }
 255
 256             goto $exporter;
 257         };
 258     }
 259 }
 260
 261 sub _strip_traits {
 262     my $idx = first_index { $_ eq '-traits' } @_;
 263
 264     return ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
 265
 266     my $traits = $_[ $idx + 1 ];
 267
 268     splice @_, $idx, 2;
 269
 270     $traits = [ $traits ] unless ref $traits;
 271
 272     return ( $traits, @_ );
 273 }
 274
 275 sub _apply_meta_traits {
 276     my ( $class, $traits ) = @_;
 277
 278     return unless @{$traits};
 279
 280     my $meta = $class->meta();
 281
 282     my $type = ( split /::/, ref $meta )[-1]
 283         or Moose->throw_error(
 284         'Cannot determine metaclass type for trait application . Meta isa '
 285         . ref $meta );
 286
 287     my @resolved_traits
 288         = map { Moose::Util::resolve_metatrait_alias( $type => $_ ) }
 289         @$traits;
 290
 291     return unless @resolved_traits;
 292
 293     Moose::Util::MetaRole::apply_metaclass_roles(
 294         for_class       => $class,
 295         metaclass_roles => \@resolved_traits,
 296     );
 297 }
 298
 299 sub _get_caller {
 300     # 1 extra level because it's called by import so there's a layer
 301     # of indirection
 302     my $offset = 1;
 303
 304     return
 305           ( ref $_[1] && defined $_[1]->{into} ) ? $_[1]->{into}
 306         : ( ref $_[1] && defined $_[1]->{into_level} )
 307         ? caller( $offset + $_[1]->{into_level} )
 308         : caller($offset);
 309 }
 310
 311 sub _make_unimport_sub {
 312     shift;
 313     my $exporting_package = shift;
 314     my $exports           = shift;
 315     my $is_removable      = shift;
 316     my $export_recorder   = shift;
 317
 318     return sub {
 319         my $caller = scalar caller();
 320         Moose::Exporter->_remove_keywords(
 321             $caller,
 322             [ keys %{$exports} ],
 323             $is_removable,
 324             $export_recorder,
 325         );
 326     };
 327 }
 328
 329 sub _remove_keywords {
 330     shift;
 331     my $package          = shift;
 332     my $keywords         = shift;
 333     my $is_removable     = shift;
 334     my $recorded_exports = shift;
 335
 336     no strict 'refs';
 337
 338     foreach my $name ( @{ $keywords } ) {
 339         next unless $is_removable->{$name};
 340
 341         if ( defined &{ $package . '::' . $name } ) {
 342             my $sub = \&{ $package . '::' . $name };
 343
 344             # make sure it is from us
 345             next unless $recorded_exports->{$sub};
 346
 347             # and if it is from us, then undef the slot
 348             delete ${ $package . '::' }{$name};
 349         }
 350     }
 351 }
 352
 353 1;
 354
 355 __END__
 356
 357 =head1 NAME
 358
 359 Moose::Exporter - make an import() and unimport() just like Moose.pm
 360
 361 =head1 SYNOPSIS
 362
 363   package MyApp::Moose;
 364
 365   use strict;
 366   use warnings;
 367
 368   use Moose ();
 369   use Moose::Exporter;
 370
 371   Moose::Exporter->setup_import_methods(
 372       with_caller => [ 'sugar1', 'sugar2' ],
 373       as_is       => [ 'sugar3', \&Some::Random::thing ],
 374       also        => 'Moose',
 375   );
 376
 377   # then later ...
 378   package MyApp::User;
 379
 380   use MyApp::Moose;
 381
 382   has 'name';
 383   sugar1 'do your thing';
 384   thing;
 385
 386   no MyApp::Moose;
 387
 388 =head1 DESCRIPTION
 389
 390 This module encapsulates the logic to export sugar functions like
 391 C<Moose.pm>. It does this by building custom C<import> and C<unimport>
 392 methods for your module, based on a spec your provide.
 393
 394 It also lets your "stack" Moose-alike modules so you can export
 395 Moose's sugar as well as your own, along with sugar from any random
 396 C<MooseX> module, as long as they all use C<Moose::Exporter>.
 397
 398 =head1 METHODS
 399
 400 This module provides two public methods:
 401
 402 =head2 Moose::Exporter->setup_import_methods(...)
 403
 404 When you call this method, C<Moose::Exporter> build custom C<import>
 405 and C<unimport> methods for your module. The import method will export
 406 the functions you specify, and you can also tell it to export
 407 functions exported by some other module (like C<Moose.pm>).
 408
 409 The C<unimport> method cleans the callers namespace of all the
 410 exported functions.
 411
 412 This method accepts the following parameters:
 413
 414 =over 4
 415
 416 =item * with_caller => [ ... ]
 417
 418 This a list of function I<names only> to be exported wrapped and then
 419 exported. The wrapper will pass the name of the calling package as the
 420 first argument to the function. Many sugar functions need to know
 421 their caller so they can get the calling package's metaclass object.
 422
 423 =item * as_is => [ ... ]
 424
 425 This a list of function names or sub references to be exported
 426 as-is. You can identify a subroutine by reference, which is handy to
 427 re-export some other module's functions directly by reference
 428 (C<\&Some::Package::function>).
 429
 430 If you do export some other packages function, this function will
 431 never be removed by the C<unimport> method. The reason for this is we
 432 cannot know if the caller I<also> explicitly imported the sub
 433 themselves, and therefore wants to keep it.
 434
 435 =item * also => $name or \@names
 436
 437 This is a list of modules which contain functions that the caller
 438 wants to export. These modules must also use C<Moose::Exporter>. The
 439 most common use case will be to export the functions from C<Moose.pm>.
 440
 441 C<Moose::Exporter> also makes sure all these functions get removed
 442 when C<unimport> is called.
 443
 444 =back
 445
 446 =head2 Moose::Exporter->build_import_methods(...)
 447
 448 Returns two code refs, one for import and one for unimport.
 449
 450 Used by C<setup_import_methods>.
 451
 452 =head1 IMPORTING AND init_meta
 453
 454 If you want to set an alternative base object class or metaclass
 455 class, simply define an C<init_meta> method in your class. The
 456 C<import> method that C<Moose::Exporter> generates for you will call
 457 this method (if it exists). It will always pass the caller to this
 458 method via the C<for_class> parameter.
 459
 460 Most of the time, your C<init_meta> method will probably just call C<<
 461 Moose->init_meta >> to do the real work:
 462
 463   sub init_meta {
 464       shift; # our class name
 465       return Moose->init_meta( @_, metaclass => 'My::Metaclass' );
 466   }
 467
 468 =head1 METACLASS TRAITS
 469
 470 The C<import> method generated by C<Moose::Exporter> will allow the
 471 user of your module to specify metaclass traits in a C<-traits>
 472 parameter passed as part of the import:
 473
 474   use Moose -traits => 'My::Meta::Trait';
 475
 476   use Moose -traits => [ 'My::Meta::Trait', 'My::Other::Trait' ];
 477
 478 These traits will be applied to the caller's metaclass
 479 instance. Providing traits for an exporting class that does not create
 480 a metaclass for the caller is an error.
 481
 482 =head1 AUTHOR
 483
 484 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 485
 486 This is largely a reworking of code in Moose.pm originally written by
 487 Stevan Little and others.
 488
 489 =head1 COPYRIGHT AND LICENSE
 490
 491 Copyright 2008 by Infinity Interactive, Inc.
 492
 493 L<http://www.iinteractive.com>
 494
 495 This library is free software; you can redistribute it and/or modify
 496 it under the same terms as Perl itself.
 497
 498 =cut