lib/Moose/Exporter.pm

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