lib/Moose/Exporter.pm

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