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