lib/Moose/Exporter.pm

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