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 => [ 'has_rw', 'sugar2' ],
 373       as_is       => [ 'sugar3', \&Some::Random::thing ],
 374       also        => 'Moose',
 375   );
 376
 377   sub has_rw {
 378       my ($caller, $class, $name, %options) = @_;
 379       Class::MOP::Class->initialize($caller)->add_attribute($name,
 380           is => 'rw',
 381           %options,
 382       );
 383   }
 384
 385   # then later ...
 386   package MyApp::User;
 387
 388   use MyApp::Moose;
 389
 390   has 'name';
 391   sugar1 'do your thing';
 392   thing;
 393
 394   no MyApp::Moose;
 395
 396 =head1 DESCRIPTION
 397
 398 This module encapsulates the logic to export sugar functions like
 399 C<Moose.pm>. It does this by building custom C<import> and C<unimport>
 400 methods for your module, based on a spec your provide.
 401
 402 It also lets your "stack" Moose-alike modules so you can export
 403 Moose's sugar as well as your own, along with sugar from any random
 404 C<MooseX> module, as long as they all use C<Moose::Exporter>.
 405
 406 =head1 METHODS
 407
 408 This module provides two public methods:
 409
 410 =head2 Moose::Exporter->setup_import_methods(...)
 411
 412 When you call this method, C<Moose::Exporter> build custom C<import>
 413 and C<unimport> methods for your module. The import method will export
 414 the functions you specify, and you can also tell it to export
 415 functions exported by some other module (like C<Moose.pm>).
 416
 417 The C<unimport> method cleans the callers namespace of all the
 418 exported functions.
 419
 420 This method accepts the following parameters:
 421
 422 =over 4
 423
 424 =item * with_caller => [ ... ]
 425
 426 This a list of function I<names only> to be exported wrapped and then
 427 exported. The wrapper will pass the name of the calling package as the
 428 first argument to the function. Many sugar functions need to know
 429 their caller so they can get the calling package's metaclass object.
 430
 431 =item * as_is => [ ... ]
 432
 433 This a list of function names or sub references to be exported
 434 as-is. You can identify a subroutine by reference, which is handy to
 435 re-export some other module's functions directly by reference
 436 (C<\&Some::Package::function>).
 437
 438 If you do export some other packages function, this function will
 439 never be removed by the C<unimport> method. The reason for this is we
 440 cannot know if the caller I<also> explicitly imported the sub
 441 themselves, and therefore wants to keep it.
 442
 443 =item * also => $name or \@names
 444
 445 This is a list of modules which contain functions that the caller
 446 wants to export. These modules must also use C<Moose::Exporter>. The
 447 most common use case will be to export the functions from C<Moose.pm>.
 448
 449 C<Moose::Exporter> also makes sure all these functions get removed
 450 when C<unimport> is called.
 451
 452 =back
 453
 454 =head2 Moose::Exporter->build_import_methods(...)
 455
 456 Returns two code refs, one for import and one for unimport.
 457
 458 Used by C<setup_import_methods>.
 459
 460 =head1 IMPORTING AND init_meta
 461
 462 If you want to set an alternative base object class or metaclass
 463 class, simply define an C<init_meta> method in your class. The
 464 C<import> method that C<Moose::Exporter> generates for you will call
 465 this method (if it exists). It will always pass the caller to this
 466 method via the C<for_class> parameter.
 467
 468 Most of the time, your C<init_meta> method will probably just call C<<
 469 Moose->init_meta >> to do the real work:
 470
 471   sub init_meta {
 472       shift; # our class name
 473       return Moose->init_meta( @_, metaclass => 'My::Metaclass' );
 474   }
 475
 476 =head1 METACLASS TRAITS
 477
 478 The C<import> method generated by C<Moose::Exporter> will allow the
 479 user of your module to specify metaclass traits in a C<-traits>
 480 parameter passed as part of the import:
 481
 482   use Moose -traits => 'My::Meta::Trait';
 483
 484   use Moose -traits => [ 'My::Meta::Trait', 'My::Other::Trait' ];
 485
 486 These traits will be applied to the caller's metaclass
 487 instance. Providing traits for an exporting class that does not create
 488 a metaclass for the caller is an error.
 489
 490 =head1 AUTHOR
 491
 492 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 493
 494 This is largely a reworking of code in Moose.pm originally written by
 495 Stevan Little and others.
 496
 497 =head1 COPYRIGHT AND LICENSE
 498
 499 Copyright 2008 by Infinity Interactive, Inc.
 500
 501 L<http://www.iinteractive.com>
 502
 503 This library is free software; you can redistribute it and/or modify
 504 it under the same terms as Perl itself.
 505
 506 =cut