X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FExporter.pm;h=80f77a1ce08fa3e4285aeb17ed8749d3fb15d04d;hb=55d05fb16429c2150b5337b1a0130ae334e129d0;hp=193d815c111830e07cec85a2782a14e98ca9441e;hpb=2c9c87972e8fc59e67cdf519795408a309a85ba3;p=gitmo%2FMoose.git diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm index 193d815..80f77a1 100644 --- a/lib/Moose/Exporter.pm +++ b/lib/Moose/Exporter.pm @@ -3,25 +3,52 @@ package Moose::Exporter; use strict; use warnings; +our $VERSION = '1.12'; +our $XS_VERSION = $VERSION; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + use Class::MOP; -use List::MoreUtils qw( uniq ); -use Sub::Exporter; +use List::MoreUtils qw( first_index uniq ); +use Moose::Deprecated; +use Moose::Util::MetaRole; +use Sub::Exporter 0.980; +use Sub::Name qw(subname); + +use XSLoader; +XSLoader::load( 'Moose', $XS_VERSION ); my %EXPORT_SPEC; +sub setup_import_methods { + my ( $class, %args ) = @_; + + my $exporting_package = $args{exporting_package} ||= caller(); + + $class->build_import_methods( + %args, + install => [qw(import unimport init_meta)] + ); +} + sub build_import_methods { - my $class = shift; - my %args = @_; + my ( $class, %args ) = @_; - my $exporting_package = caller(); + my $exporting_package = $args{exporting_package} ||= caller(); $EXPORT_SPEC{$exporting_package} = \%args; - my @exports_from = $class->_follow_also( $exporting_package ); + my @exports_from = $class->_follow_also($exporting_package); - my $exports - = $class->_process_exports( $exporting_package, @exports_from ); + my $export_recorder = {}; + my $is_reexport = {}; + + my $exports = $class->_make_sub_exporter_params( + [ @exports_from, $exporting_package ], + $export_recorder, + $is_reexport, + ); my $exporter = Sub::Exporter::build_exporter( { @@ -30,23 +57,46 @@ sub build_import_methods { } ); - my $import = $class->_make_import_sub( $exporter, \@exports_from ); + my %methods; + $methods{import} = $class->_make_import_sub( + $exporting_package, + $exporter, + \@exports_from, + $is_reexport + ); + + $methods{unimport} = $class->_make_unimport_sub( + $exporting_package, + $exports, + $export_recorder, + $is_reexport + ); + + $methods{init_meta} = $class->_make_init_meta( + $exporting_package, + \%args + ); - my $unimport = $class->_make_unimport_sub( [ keys %{$exports} ] ); + my $package = Class::MOP::Package->initialize($exporting_package); + for my $to_install ( @{ $args{install} || [] } ) { + my $symbol = '&' . $to_install; + next + unless $methods{$to_install} + && !$package->has_package_symbol($symbol); + $package->add_package_symbol( $symbol, $methods{$to_install} ); + } - no strict 'refs'; - *{ $exporting_package . '::import' } = $import; - *{ $exporting_package . '::unimport' } = $unimport; + return ( $methods{import}, $methods{unimport}, $methods{init_meta} ); } { - my %seen; + my $seen = {}; sub _follow_also { my $class = shift; my $exporting_package = shift; - %seen = ( $exporting_package => 1 ); + local %$seen = ( $exporting_package => 1 ); return uniq( _follow_also_real($exporting_package) ); } @@ -54,8 +104,13 @@ sub build_import_methods { sub _follow_also_real { my $exporting_package = shift; - die "Package in also ($exporting_package) does not seem to use MooseX::Exporter" - unless exists $EXPORT_SPEC{$exporting_package}; + if ( !exists $EXPORT_SPEC{$exporting_package} ) { + my $loaded = Class::MOP::is_class_loaded($exporting_package); + + die "Package in also ($exporting_package) does not seem to " + . "use Moose::Exporter" + . ( $loaded ? "" : " (is it loaded?)" ); + } my $also = $EXPORT_SPEC{$exporting_package}{also}; @@ -63,133 +118,338 @@ sub build_import_methods { my @also = ref $also ? @{$also} : $also; - for my $package (@also) - { - die "Circular reference in also parameter to MooseX::Exporter between $exporting_package and $package" - if $seen{$package}; + for my $package (@also) { + die + "Circular reference in 'also' parameter to Moose::Exporter between $exporting_package and $package" + if $seen->{$package}; - $seen{$package} = 1; + $seen->{$package} = 1; } return @also, map { _follow_also_real($_) } @also; } } -sub _process_exports { - my $class = shift; - my @packages = @_; +sub _make_sub_exporter_params { + my $class = shift; + my $packages = shift; + my $export_recorder = shift; + my $is_reexport = shift; my %exports; - for my $package (@packages) { + for my $package ( @{$packages} ) { my $args = $EXPORT_SPEC{$package} or die "The $package package does not use Moose::Exporter\n"; + for my $name ( @{ $args->{with_meta} } ) { + my $sub = $class->_sub_from_package( $package, $name ) + or next; + + my $fq_name = $package . '::' . $name; + + $exports{$name} = $class->_make_wrapped_sub_with_meta( + $fq_name, + $sub, + $export_recorder, + ); + } + for my $name ( @{ $args->{with_caller} } ) { - my $sub = do { - no strict 'refs'; - \&{ $package . '::' . $name }; - }; + my $sub = $class->_sub_from_package( $package, $name ) + or next; + + my $fq_name = $package . '::' . $name; $exports{$name} = $class->_make_wrapped_sub( - $package, - $name, - $sub + $fq_name, + $sub, + $export_recorder, ); } for my $name ( @{ $args->{as_is} } ) { - my $sub; + my ( $sub, $coderef_name ); if ( ref $name ) { - $sub = $name; - $name = ( Class::MOP::get_code_info($name) )[1]; + $sub = $name; + + my $coderef_pkg; + ( $coderef_pkg, $coderef_name ) + = Class::MOP::get_code_info($name); + + if ( $coderef_pkg ne $package ) { + $is_reexport->{$coderef_name} = 1; + } } else { - $sub = do { - no strict 'refs'; - \&{ $package . '::' . $name }; - }; + $sub = $class->_sub_from_package( $package, $name ) + or next; + + $coderef_name = $name; } - $exports{$name} = sub {$sub}; + $export_recorder->{$sub} = 1; + + $exports{$coderef_name} = sub {$sub}; } } return \%exports; } -{ - # This variable gets closed over in each export _generator_. Then - # in the generator we grab the value and close over it _again_ in - # the real export, so it gets captured each time the generator - # runs. - # - # In the meantime, we arrange for the import method we generate to - # set this variable to the caller each time it is called. - # - # This is all a bit confusing, but it works. - my $CALLER; - - sub _make_wrapped_sub { - my $class = shift; - my $exporting_package = shift; - my $name = shift; - my $sub = shift; - - # We need to set the package at import time, so that when - # package Foo imports has(), we capture "Foo" as the - # package. This lets other packages call Foo::has() and get - # the right package. This is done for backwards compatibility - # with existing production code, not because this is a good - # idea ;) - return sub { - my $caller = $CALLER; - Class::MOP::subname( $exporting_package . '::' - . $name => sub { $sub->( $caller, @_ ) } ); - }; +sub _sub_from_package { + my $sclass = shift; + my $package = shift; + my $name = shift; + + my $sub = do { + no strict 'refs'; + \&{ $package . '::' . $name }; + }; + + return $sub if defined &$sub; + + Carp::cluck "Trying to export undefined sub ${package}::${name}"; + + return; +} + +our $CALLER; + +sub _make_wrapped_sub { + my $self = shift; + my $fq_name = shift; + my $sub = shift; + my $export_recorder = shift; + + # We need to set the package at import time, so that when + # package Foo imports has(), we capture "Foo" as the + # package. This lets other packages call Foo::has() and get + # the right package. This is done for backwards compatibility + # with existing production code, not because this is a good + # idea ;) + return sub { + my $caller = $CALLER; + + my $wrapper = $self->_curry_wrapper( $sub, $fq_name, $caller ); + + my $sub = subname( $fq_name => $wrapper ); + + $export_recorder->{$sub} = 1; + + return $sub; + }; +} + +sub _make_wrapped_sub_with_meta { + my $self = shift; + my $fq_name = shift; + my $sub = shift; + my $export_recorder = shift; + + return sub { + my $caller = $CALLER; + + my $wrapper = $self->_late_curry_wrapper( + $sub, $fq_name, + sub { Class::MOP::class_of(shift) } => $caller + ); + + my $sub = subname( $fq_name => $wrapper ); + + $export_recorder->{$sub} = 1; + + return $sub; + }; +} + +sub _curry_wrapper { + my $class = shift; + my $sub = shift; + my $fq_name = shift; + my @extra = @_; + + my $wrapper = sub { $sub->( @extra, @_ ) }; + if ( my $proto = prototype $sub ) { + + # XXX - Perl's prototype sucks. Use & to make set_prototype + # ignore the fact that we're passing "private variables" + &Scalar::Util::set_prototype( $wrapper, $proto ); } + return $wrapper; +} - sub _make_import_sub { - shift; - my $exporter = shift; - my $exports_from = shift; +sub _late_curry_wrapper { + my $class = shift; + my $sub = shift; + my $fq_name = shift; + my $extra = shift; + my @ex_args = @_; - return sub { + my $wrapper = sub { - # It's important to leave @_ as-is for the benefit of - # Sub::Exporter. - my $class = $_[0]; + # resolve curried arguments at runtime via this closure + my @curry = ( $extra->(@ex_args) ); + return $sub->( @curry, @_ ); + }; - $CALLER = Moose::Exporter::_get_caller(@_); + if ( my $proto = prototype $sub ) { - # this works because both pragmas set $^H (see perldoc - # perlvar) which affects the current compilation - - # i.e. the file who use'd us - which is why we don't need - # to do anything special to make it affect that file - # rather than this one (which is already compiled) + # XXX - Perl's prototype sucks. Use & to make set_prototype + # ignore the fact that we're passing "private variables" + &Scalar::Util::set_prototype( $wrapper, $proto ); + } + return $wrapper; +} - strict->import; - warnings->import; +sub _make_import_sub { + shift; + my $exporting_package = shift; + my $exporter = shift; + my $exports_from = shift; + my $is_reexport = shift; - # we should never export to main - if ( $CALLER eq 'main' ) { - warn - qq{$class does not export its sugar to the 'main' package.\n}; - return; - } + return sub { - for my $c (grep { $_->can('init_meta') } $class, @{$exports_from} ) { + # I think we could use Sub::Exporter's collector feature + # to do this, but that would be rather gross, since that + # feature isn't really designed to return a value to the + # caller of the exporter sub. + # + # Also, this makes sure we preserve backwards compat for + # _get_caller, so it always sees the arguments in the + # expected order. + my $traits; + ( $traits, @_ ) = _strip_traits(@_); + + my $metaclass; + ( $metaclass, @_ ) = _strip_metaclass(@_); + $metaclass + = Moose::Util::resolve_metaclass_alias( 'Class' => $metaclass ) + if defined $metaclass && length $metaclass; + + # Normally we could look at $_[0], but in some weird cases + # (involving goto &Moose::import), $_[0] ends as something + # else (like Squirrel). + my $class = $exporting_package; + + $CALLER = _get_caller(@_); + + # this works because both pragmas set $^H (see perldoc + # perlvar) which affects the current compilation - + # i.e. the file who use'd us - which is why we don't need + # to do anything special to make it affect that file + # rather than this one (which is already compiled) + + strict->import; + warnings->import; + + my $did_init_meta; + for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) { + + # init_meta can apply a role, which when loaded uses + # Moose::Exporter, which in turn sets $CALLER, so we need + # to protect against that. + local $CALLER = $CALLER; + $c->init_meta( for_class => $CALLER, metaclass => $metaclass ); + $did_init_meta = 1; + } - $c->init_meta( for_class => $CALLER ); - } + if ( $did_init_meta && @{$traits} ) { + + # The traits will use Moose::Role, which in turn uses + # Moose::Exporter, which in turn sets $CALLER, so we need + # to protect against that. + local $CALLER = $CALLER; + _apply_meta_traits( $CALLER, $traits ); + } + elsif ( @{$traits} ) { + require Moose; + Moose->throw_error( + "Cannot provide traits when $class does not have an init_meta() method" + ); + } + + my ( undef, @args ) = @_; + my $extra = shift @args if ref $args[0] eq 'HASH'; + + $extra ||= {}; + if ( !$extra->{into} ) { + $extra->{into_level} ||= 0; + $extra->{into_level}++; + } + + $class->$exporter( $extra, @args ); + + for my $name ( keys %{$is_reexport} ) { + no strict 'refs'; + no warnings 'once'; + _flag_as_reexport( \*{ join q{::}, $CALLER, $name } ); + } + }; +} + +sub _strip_traits { + my $idx = first_index { $_ eq '-traits' } @_; + + return ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1; + + my $traits = $_[ $idx + 1 ]; - goto $exporter; - }; + splice @_, $idx, 2; + + $traits = [$traits] unless ref $traits; + + return ( $traits, @_ ); +} + +sub _strip_metaclass { + my $idx = first_index { $_ eq '-metaclass' } @_; + + return ( undef, @_ ) unless $idx >= 0 && $#_ >= $idx + 1; + + my $metaclass = $_[ $idx + 1 ]; + + splice @_, $idx, 2; + + return ( $metaclass, @_ ); +} + +sub _apply_meta_traits { + my ( $class, $traits ) = @_; + + return unless @{$traits}; + + my $meta = Class::MOP::class_of($class); + + my $type = ( split /::/, ref $meta )[-1] + or Moose->throw_error( + 'Cannot determine metaclass type for trait application . Meta isa ' + . ref $meta ); + + my @resolved_traits = map { + ref $_ + ? $_ + : Moose::Util::resolve_metatrait_alias( $type => $_ ) + } @$traits; + + return unless @resolved_traits; + + my %args = ( for => $class ); + + if ( $meta->isa('Moose::Meta::Role') ) { + $args{role_metaroles} = { role => \@resolved_traits }; } + else { + $args{class_metaroles} = { class => \@resolved_traits }; + } + + Moose::Util::MetaRole::apply_metaroles(%args); } sub _get_caller { + # 1 extra level because it's called by import so there's a layer # of indirection my $offset = 1; @@ -202,32 +462,45 @@ sub _get_caller { } sub _make_unimport_sub { - my $class = shift; - my $exported = shift; + shift; + my $exporting_package = shift; + my $exports = shift; + my $export_recorder = shift; + my $is_reexport = shift; return sub { my $caller = scalar caller(); - Moose::Exporter->_remove_keywords( $caller, $exported ); + Moose::Exporter->_remove_keywords( + $caller, + [ keys %{$exports} ], + $export_recorder, + $is_reexport, + ); }; } sub _remove_keywords { shift; - my $package = shift; - my $keywords = shift; + my $package = shift; + my $keywords = shift; + my $recorded_exports = shift; + my $is_reexport = shift; no strict 'refs'; - # loop through the keywords ... foreach my $name ( @{$keywords} ) { - - # if we find one ... if ( defined &{ $package . '::' . $name } ) { - my $keyword = \&{ $package . '::' . $name }; + my $sub = \&{ $package . '::' . $name }; # make sure it is from us - my ($pkg_name) = Class::MOP::get_code_info($keyword); - next if $pkg_name eq $package; + next unless $recorded_exports->{$sub}; + + if ( $is_reexport->{$name} ) { + no strict 'refs'; + next + unless _export_is_flagged( + \*{ join q{::} => $package, $name } ); + } # and if it is from us, then undef the slot delete ${ $package . '::' }{$name}; @@ -235,6 +508,68 @@ sub _remove_keywords { } } +sub _make_init_meta { + shift; + my $class = shift; + my $args = shift; + + my %old_style_roles; + for my $role ( + map {"${_}_roles"} + qw( + metaclass + attribute_metaclass + method_metaclass + wrapped_method_metaclass + instance_metaclass + constructor_class + destructor_class + error_class + ) + ) { + $old_style_roles{$role} = $args->{$role} + if exists $args->{$role}; + } + + my %base_class_roles; + %base_class_roles = ( roles => $args->{base_class_roles} ) + if exists $args->{base_class_roles}; + + my %new_style_roles = map { $_ => $args->{$_} } + grep { exists $args->{$_} } qw( class_metaroles role_metaroles ); + + return unless %new_style_roles || %old_style_roles || %base_class_roles; + + return sub { + shift; + my %options = @_; + + return unless Class::MOP::class_of( $options{for_class} ); + + if ( %new_style_roles || %old_style_roles ) { + Moose::Util::MetaRole::apply_metaroles( + for => $options{for_class}, + %new_style_roles, + %old_style_roles, + ); + } + + Moose::Util::MetaRole::apply_base_class_roles( + for_class => $options{for_class}, + %base_class_roles, + ) + if Class::MOP::class_of( $options{for_class} ) + ->isa('Moose::Meta::Class'); + + return Class::MOP::class_of( $options{for_class} ); + }; +} + +sub import { + strict->import; + warnings->import; +} + 1; __END__ @@ -247,76 +582,202 @@ Moose::Exporter - make an import() and unimport() just like Moose.pm package MyApp::Moose; - use strict; - use warnings; - use Moose (); use Moose::Exporter; - Moose::Exporter->build_export_methods( - export => [ 'sugar1', 'sugar2', \&Some::Random::thing ], - init_meta_args => { metaclass_class => 'MyApp::Meta::Class' ], + Moose::Exporter->setup_import_methods( + with_meta => [ 'has_rw', 'sugar2' ], + as_is => [ 'sugar3', \&Some::Random::thing ], + also => 'Moose', ); + sub has_rw { + my ( $meta, $name, %options ) = @_; + $meta->add_attribute( + $name, + is => 'rw', + %options, + ); + } + # then later ... package MyApp::User; use MyApp::Moose; has 'name'; - sugar1 'do your thing'; + has_rw 'size'; thing; no MyApp::Moose; =head1 DESCRIPTION -This module encapsulates the logic to export sugar functions like -C. It does this by building custom C and C -methods for your module, based on a spec your provide. +This module encapsulates the exporting of sugar functions in a +C-like manner. It does this by building custom C, +C, and C methods for your module, based on a spec you +provide. + +It also lets you "stack" Moose-alike modules so you can export Moose's sugar +as well as your own, along with sugar from any random C module, as +long as they all use C. This feature exists to let you bundle +a set of MooseX modules into a policy module that developers can use directly +instead of using Moose itself. -It also lets your "stack" Moose-alike modules so you can export -Moose's sugar as well as your own, along with sugar from any random -C module, as long as they all use C. +To simplify writing exporter modules, C also imports +C and C into your exporter module, as well as into +modules that use it. =head1 METHODS -This module provides exactly one public method: +This module provides two public methods: -=head2 Moose::Exporter->build_import_methods(...) +=over 4 -When you call this method, C build custom C -and C methods for your module. The import method will export -the functions you specify, and you can also tell it to export -functions exported by some other module (like C). +=item B<< Moose::Exporter->setup_import_methods(...) >> -The C method cleans the callers namespace of all the -exported functions. +When you call this method, C builds custom C, +C, and C methods for your module. The C method +will export the functions you specify, and can also re-export functions +exported by some other module (like C). + +The C method cleans the caller's namespace of all the exported +functions. This includes any functions you re-export from other +packages. However, if the consumer of your package also imports those +functions from the original package, they will I be cleaned. + +If you pass any parameters for L, this method will +generate an C for you as well (see below for details). This +C will call C and +C as needed. + +Note that if any of these methods already exist, they will not be +overridden, you will have to use C to get the +coderef that would be installed. This method accepts the following parameters: -=over 4 +=over 8 + +=item * with_meta => [ ... ] -=item * with_caller => [ ... ] +This list of function I will be wrapped and then exported. The +wrapper will pass the metaclass object for the caller as its first argument. -This a list of function I to be exported wrapped and then -exported. The wrapper will pass the name of the calling package as the -first argument to the function. Many sugar functions need to know -their caller so they can get the calling package's metaclass object. +Many sugar functions will need to use this metaclass object to do something to +the calling package. =item * as_is => [ ... ] -This a list of function names or sub references to be exported -as-is. You can identify a subroutine by reference, which is handy to -re-export some other module's functions directly by reference -(C<\&Some::Package::function>). +This list of function names or sub references will be exported as-is. You can +identify a subroutine by reference, which is handy to re-export some other +module's functions directly by reference (C<\&Some::Package::function>). -=item * init_meta_args +If you do export some other package's function, this function will never be +removed by the C method. The reason for this is we cannot know if +the caller I explicitly imported the sub themselves, and therefore wants +to keep it. -... +=item * also => $name or \@names + +This is a list of modules which contain functions that the caller +wants to export. These modules must also use C. The +most common use case will be to export the functions from C. +Functions specified by C or C take precedence over +functions exported by modules specified by C, so that a module +can selectively override functions exported by another module. + +C also makes sure all these functions get removed +when C is called. =back +You can also provide parameters for C +and C. Specifically, valid parameters +are "class_metaroles", "role_metaroles", and "base_class_roles". + +=item B<< Moose::Exporter->build_import_methods(...) >> + +Returns two or three code refs, one for C, one for +C, and optionally one for C, if the appropriate +options are passed in. + +Accepts the additional C option, which accepts an arrayref of method +names to install into your exporting package. The valid options are C, +C, and C. Calling C is equivalent +to calling C with C<< install => [qw(import unimport +init_meta)] >> except that it doesn't also return the methods. + +Used by C. + +=back + +=head1 IMPORTING AND init_meta + +If you want to set an alternative base object class or metaclass class, see +above for details on how this module can call L for +you. + +If you want to do something that is not supported by this module, simply +define an C method in your class. The C method that +C generates for you will call this method (if it exists). It +will always pass the caller to this method via the C parameter. + +Most of the time, your C method will probably just call C<< +Moose->init_meta >> to do the real work: + + sub init_meta { + shift; # our class name + return Moose->init_meta( @_, metaclass => 'My::Metaclass' ); + } + +Keep in mind that C will return an C +method for you, which you can also call from within your custom +C: + + my ( $import, $unimport, $init_meta ) = + Moose::Exporter->build_import_methods( ... ); + + sub import { + my $class = shift; + + ... + + $class->$import(...); + + ... + } + + sub unimport { goto &$unimport } + + sub init_meta { + my $class = shift; + + ... + + $class->$init_meta(...); + + ... + } + +=head1 METACLASS TRAITS + +The C method generated by C will allow the +user of your module to specify metaclass traits in a C<-traits> +parameter passed as part of the import: + + use Moose -traits => 'My::Meta::Trait'; + + use Moose -traits => [ 'My::Meta::Trait', 'My::Other::Trait' ]; + +These traits will be applied to the caller's metaclass +instance. Providing traits for an exporting class that does not create +a metaclass for the caller is an error. + +=head1 BUGS + +See L for details on reporting bugs. + =head1 AUTHOR Dave Rolsky Eautarch@urth.orgE @@ -326,7 +787,7 @@ Stevan Little and others. =head1 COPYRIGHT AND LICENSE -Copyright 2008 by Infinity Interactive, Inc. +Copyright 2009 by Infinity Interactive, Inc. L