lib/Moose/Exporter.pm

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