lib/Moose/Exporter.pm

   1 package Moose::Exporter;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION   = '0.89';
   7 $VERSION = eval $VERSION;
   8 our $AUTHORITY = 'cpan:STEVAN';
   9
  10 use Class::MOP;
  11 use List::MoreUtils qw( 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 _strip_command {
 351     my($args, %commands) = @_;
 352
 353     for (my $i = 0; $i < @{$args}; $i++) {
 354         if ( my $slot_ref = $commands{$args->[$i]} ) {
 355             my $arg = $args->[$i+1];
 356             splice @{$args}, $i, 2;
 357
 358             if ( ref($slot_ref) eq 'ARRAY' ) {
 359                 @{$slot_ref} = ref($arg) eq 'ARRAY' ? @{$arg} : $arg;
 360             }
 361             else {
 362                 ${$slot_ref} = $arg;
 363             }
 364         }
 365     }
 366     return;
 367 }
 368
 369 sub _make_import_sub {
 370     shift;
 371     my $exporting_package = shift;
 372     my $exporter          = shift;
 373     my $exports_from      = shift;
 374     my $export_to_main    = shift;
 375
 376     return sub {
 377
 378         # I think we could use Sub::Exporter's collector feature
 379         # to do this, but that would be rather gross, since that
 380         # feature isn't really designed to return a value to the
 381         # caller of the exporter sub.
 382         #
 383         # Also, this makes sure we preserve backwards compat for
 384         # _get_caller, so it always sees the arguments in the
 385         # expected order.
 386
 387         my $metaclass;
 388         my @traits;
 389         my @superclasses;
 390
 391         _strip_command(\@_,
 392             -metaclass => \$metaclass,
 393             -traits    => \@traits,
 394             -extends   => \@superclasses,
 395         );
 396
 397         $metaclass = Moose::Util::resolve_metaclass_alias(
 398             'Class' => $metaclass
 399         ) if defined $metaclass && length $metaclass;
 400
 401         # Normally we could look at $_[0], but in some weird cases
 402         # (involving goto &Moose::import), $_[0] ends as something
 403         # else (like Squirrel).
 404         my $class = $exporting_package;
 405
 406
 407         $CALLER = _get_caller(@_);
 408
 409         # this works because both pragmas set $^H (see perldoc
 410         # perlvar) which affects the current compilation -
 411         # i.e. the file who use'd us - which is why we don't need
 412         # to do anything special to make it affect that file
 413         # rather than this one (which is already compiled)
 414
 415         strict->import;
 416         warnings->import;
 417
 418         # we should never export to main
 419         if ( $CALLER eq 'main' && !$export_to_main ) {
 420             warn
 421                 qq{$class does not export its sugar to the 'main' package.\n};
 422             return;
 423         }
 424
 425         my $did_init_meta;
 426         for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) {
 427             # init_meta() can load classes using Moose or Moose::Role,
 428             # which uses Moose::Exporter, which in turn sets $CALLER, so we need
 429             # to protect against that.
 430             local $CALLER = $CALLER;
 431             $c->init_meta( for_class => $CALLER, metaclass => $metaclass );
 432             $did_init_meta = 1;
 433         }
 434
 435         if ( @superclasses ) {
 436             if ( $did_init_meta ) {
 437                 # superclasses() can load classes using Moose or Moose::Role,
 438                 # which uses Moose::Exporter, which in turn sets $CALLER, so we need
 439                 # to protect against that.
 440                 local $CALLER = $CALLER;
 441                 $CALLER->meta->superclasses(@superclasses);
 442             }
 443             else {
 444                 require Moose;
 445                 Moose->throw_error(
 446                     "Cannot provide -extends when $class does not have an init_meta() method"
 447                 );
 448             }
 449         }
 450
 451         if ( @traits ) {
 452             if ( $did_init_meta ) {
 453                 # _apply_meta_traits() can load classes using Moose or Moose::Role,
 454                 # which uses Moose::Exporter, which in turn sets $CALLER, so we need
 455                 # to protect against that.
 456                 local $CALLER = $CALLER;
 457                 _apply_meta_traits( $CALLER, \@traits );
 458             }
 459             else {
 460                 require Moose;
 461                 Moose->throw_error(
 462                     "Cannot provide traits when $class does not have an init_meta() method"
 463                 );
 464             }
 465         }
 466
 467         goto $exporter;
 468     };
 469 }
 470
 471 sub _apply_meta_traits {
 472     my ( $class, $traits ) = @_;
 473
 474     return unless @{$traits};
 475
 476     my $meta = Class::MOP::class_of($class);
 477
 478     my $type = ( split /::/, ref $meta )[-1]
 479         or Moose->throw_error(
 480         'Cannot determine metaclass type for trait application . Meta isa '
 481         . ref $meta );
 482
 483     my @resolved_traits
 484         = map {
 485             ref $_ ? $_ : Moose::Util::resolve_metatrait_alias( $type => $_ )
 486         }
 487         @$traits;
 488
 489     return unless @resolved_traits;
 490
 491     Moose::Util::MetaRole::apply_metaclass_roles(
 492         for_class       => $class,
 493         metaclass_roles => \@resolved_traits,
 494     );
 495 }
 496
 497 sub _get_caller {
 498     # 1 extra level because it's called by import so there's a layer
 499     # of indirection
 500     my $offset = 1;
 501
 502     return
 503           ( ref $_[1] && defined $_[1]->{into} ) ? $_[1]->{into}
 504         : ( ref $_[1] && defined $_[1]->{into_level} )
 505         ? caller( $offset + $_[1]->{into_level} )
 506         : caller($offset);
 507 }
 508
 509 sub _make_unimport_sub {
 510     shift;
 511     my $exporting_package = shift;
 512     my $exports           = shift;
 513     my $is_removable      = shift;
 514     my $export_recorder   = shift;
 515
 516     return sub {
 517         my $caller = scalar caller();
 518         Moose::Exporter->_remove_keywords(
 519             $caller,
 520             [ keys %{$exports} ],
 521             $is_removable,
 522             $export_recorder,
 523         );
 524     };
 525 }
 526
 527 sub _remove_keywords {
 528     shift;
 529     my $package          = shift;
 530     my $keywords         = shift;
 531     my $is_removable     = shift;
 532     my $recorded_exports = shift;
 533
 534     no strict 'refs';
 535
 536     foreach my $name ( @{ $keywords } ) {
 537         next unless $is_removable->{$name};
 538
 539         if ( defined &{ $package . '::' . $name } ) {
 540             my $sub = \&{ $package . '::' . $name };
 541
 542             # make sure it is from us
 543             next unless $recorded_exports->{$sub};
 544
 545             # and if it is from us, then undef the slot
 546             delete ${ $package . '::' }{$name};
 547         }
 548     }
 549 }
 550
 551 sub import {
 552     strict->import;
 553     warnings->import;
 554 }
 555
 556 1;
 557
 558 __END__
 559
 560 =head1 NAME
 561
 562 Moose::Exporter - make an import() and unimport() just like Moose.pm
 563
 564 =head1 SYNOPSIS
 565
 566   package MyApp::Moose;
 567
 568   use Moose ();
 569   use Moose::Exporter;
 570
 571   Moose::Exporter->setup_import_methods(
 572       with_caller => [ 'has_rw', 'sugar2' ],
 573       as_is       => [ 'sugar3', \&Some::Random::thing ],
 574       also        => 'Moose',
 575   );
 576
 577   sub has_rw {
 578       my ($caller, $name, %options) = @_;
 579       Class::MOP::class_of($caller)->add_attribute($name,
 580           is => 'rw',
 581           %options,
 582       );
 583   }
 584
 585   # then later ...
 586   package MyApp::User;
 587
 588   use MyApp::Moose;
 589
 590   has 'name';
 591   has_rw 'size';
 592   thing;
 593
 594   no MyApp::Moose;
 595
 596 =head1 DESCRIPTION
 597
 598 This module encapsulates the exporting of sugar functions in a
 599 C<Moose.pm>-like manner. It does this by building custom C<import> and
 600 C<unimport> methods for your module, based on a spec you provide.
 601
 602 It also lets you "stack" Moose-alike modules so you can export
 603 Moose's sugar as well as your own, along with sugar from any random
 604 C<MooseX> module, as long as they all use C<Moose::Exporter>.
 605
 606 To simplify writing exporter modules, C<Moose::Exporter> also imports
 607 C<strict> and C<warnings> into your exporter module, as well as into
 608 modules that use it.
 609
 610 =head1 METHODS
 611
 612 This module provides two public methods:
 613
 614 =over 4
 615
 616 =item  B<< Moose::Exporter->setup_import_methods(...) >>
 617
 618 When you call this method, C<Moose::Exporter> build custom C<import>
 619 and C<unimport> methods for your module. The import method will export
 620 the functions you specify, and you can also tell it to export
 621 functions exported by some other module (like C<Moose.pm>).
 622
 623 The C<unimport> method cleans the callers namespace of all the
 624 exported functions.
 625
 626 This method accepts the following parameters:
 627
 628 =over 8
 629
 630 =item * with_caller => [ ... ]
 631
 632 This a list of function I<names only> to be exported wrapped and then
 633 exported. The wrapper will pass the name of the calling package as the
 634 first argument to the function. Many sugar functions need to know
 635 their caller so they can get the calling package's metaclass object.
 636
 637 =item * as_is => [ ... ]
 638
 639 This a list of function names or sub references to be exported
 640 as-is. You can identify a subroutine by reference, which is handy to
 641 re-export some other module's functions directly by reference
 642 (C<\&Some::Package::function>).
 643
 644 If you do export some other packages function, this function will
 645 never be removed by the C<unimport> method. The reason for this is we
 646 cannot know if the caller I<also> explicitly imported the sub
 647 themselves, and therefore wants to keep it.
 648
 649 =item * also => $name or \@names
 650
 651 This is a list of modules which contain functions that the caller
 652 wants to export. These modules must also use C<Moose::Exporter>. The
 653 most common use case will be to export the functions from C<Moose.pm>.
 654 Functions specified by C<with_caller> or C<as_is> take precedence over
 655 functions exported by modules specified by C<also>, so that a module
 656 can selectively override functions exported by another module.
 657
 658 C<Moose::Exporter> also makes sure all these functions get removed
 659 when C<unimport> is called.
 660
 661 =back
 662
 663 =item B<< Moose::Exporter->build_import_methods(...) >>
 664
 665 Returns two code refs, one for import and one for unimport.
 666
 667 Used by C<setup_import_methods>.
 668
 669 =back
 670
 671 =head1 IMPORTING AND init_meta
 672
 673 If you want to set an alternative base object class or metaclass
 674 class, simply define an C<init_meta> method in your class. The
 675 C<import> method that C<Moose::Exporter> generates for you will call
 676 this method (if it exists). It will always pass the caller to this
 677 method via the C<for_class> parameter.
 678
 679 Most of the time, your C<init_meta> method will probably just call C<<
 680 Moose->init_meta >> to do the real work:
 681
 682   sub init_meta {
 683       shift; # our class name
 684       return Moose->init_meta( @_, metaclass => 'My::Metaclass' );
 685   }
 686
 687 =head1 METACLASS TRAITS
 688
 689 The C<import> method generated by C<Moose::Exporter> will allow the
 690 user of your module to specify metaclass traits in a C<-traits>
 691 parameter passed as part of the import:
 692
 693   use Moose -traits => 'My::Meta::Trait';
 694
 695   use Moose -traits => [ 'My::Meta::Trait', 'My::Other::Trait' ];
 696
 697 These traits will be applied to the caller's metaclass
 698 instance. Providing traits for an exporting class that does not create
 699 a metaclass for the caller is an error.
 700
 701 =head1 AUTHOR
 702
 703 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 704
 705 This is largely a reworking of code in Moose.pm originally written by
 706 Stevan Little and others.
 707
 708 =head1 COPYRIGHT AND LICENSE
 709
 710 Copyright 2009 by Infinity Interactive, Inc.
 711
 712 L<http://www.iinteractive.com>
 713
 714 This library is free software; you can redistribute it and/or modify
 715 it under the same terms as Perl itself.
 716
 717 =cut