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