lib/Moose/Exporter.pm

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