lib/Moose/Exporter.pm

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