X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FExporter.pm;h=c8265bcbc7e8ceec2b0649a6bd25369177edc4dc;hb=1853a27e1534e9b5fd73c83a636cda8603eec63f;hp=571c9b239f582ea39328a7540fc9b160fb0f09a9;hpb=f9dfa78b1df96c4d96ff76f4a19db7ceea69be1b;p=gitmo%2FMoose.git diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm index 571c9b2..c8265bc 100644 --- a/lib/Moose/Exporter.pm +++ b/lib/Moose/Exporter.pm @@ -3,54 +3,72 @@ package Moose::Exporter; use strict; use warnings; -use Carp qw( confess ); +our $VERSION = '0.89'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + use Class::MOP; use List::MoreUtils qw( first_index uniq ); -use Sub::Exporter; - +use Moose::Util::MetaRole; +use Sub::Exporter 0.980; +use Sub::Name qw(subname); my %EXPORT_SPEC; +sub setup_import_methods { + my ( $class, %args ) = @_; + + my $exporting_package = $args{exporting_package} ||= caller(); + + my ( $import, $unimport ) = $class->build_import_methods(%args); + + no strict 'refs'; + *{ $exporting_package . '::import' } = $import; + *{ $exporting_package . '::unimport' } = $unimport; +} + 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 - = $class->_make_sub_exporter_params( $exporting_package, @exports_from ); + my $export_recorder = {}; + + my ( $exports, $is_removable, $groups ) + = $class->_make_sub_exporter_params( + [ @exports_from, $exporting_package ], $export_recorder ); my $exporter = Sub::Exporter::build_exporter( { exports => $exports, - groups => { default => [':all'] } + groups => { default => [':all'], %$groups } } ); # $args{_export_to_main} exists for backwards compat, because # Moose::Util::TypeConstraints did export to main (unlike Moose & # Moose::Role). - my $import = $class->_make_import_sub( $exporter, \@exports_from, $args{_export_to_main} ); + my $import = $class->_make_import_sub( $exporting_package, $exporter, + \@exports_from, $args{_export_to_main} ); - my $unimport = $class->_make_unimport_sub( \@exports_from, [ keys %{$exports} ] ); + my $unimport = $class->_make_unimport_sub( $exporting_package, $exports, + $is_removable, $export_recorder ); - no strict 'refs'; - *{ $exporting_package . '::import' } = $import; - *{ $exporting_package . '::unimport' } = $unimport; + return ( $import, $unimport ) } { - 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) ); } @@ -58,8 +76,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}; @@ -69,10 +92,10 @@ sub build_import_methods { for my $package (@also) { - die "Circular reference in also parameter to MooseX::Exporter between $exporting_package and $package" - if $seen{$package}; + 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; @@ -80,26 +103,59 @@ sub build_import_methods { } sub _make_sub_exporter_params { - my $class = shift; - my @packages = @_; + my $class = shift; + my $packages = shift; + my $export_recorder = shift; + my %groups; my %exports; + my %is_removable; - for my $package (@packages) { + for my $package ( @{$packages} ) { my $args = $EXPORT_SPEC{$package} or die "The $package package does not use Moose::Exporter\n"; + # one group for each 'also' package + $groups{$package} = [ + @{ $args->{with_caller} || [] }, + @{ $args->{with_meta} || [] }, + @{ $args->{as_is} || [] }, + map ":$_", + keys %{ $args->{groups} || {} } + ]; + for my $name ( @{ $args->{with_caller} } ) { my $sub = do { no strict 'refs'; \&{ $package . '::' . $name }; }; + my $fq_name = $package . '::' . $name; + $exports{$name} = $class->_make_wrapped_sub( - $package, - $name, - $sub + $fq_name, + $sub, + $export_recorder, ); + + $is_removable{$name} = 1; + } + + for my $name ( @{ $args->{with_meta} } ) { + my $sub = do { + no strict 'refs'; + \&{ $package . '::' . $name }; + }; + + my $fq_name = $package . '::' . $name; + + $exports{$name} = $class->_make_wrapped_sub_with_meta( + $fq_name, + $sub, + $export_recorder, + ); + + $is_removable{$name} = 1; } for my $name ( @{ $args->{as_is} } ) { @@ -107,117 +163,272 @@ sub _make_sub_exporter_params { if ( ref $name ) { $sub = $name; - $name = ( Class::MOP::get_code_info($name) )[1]; + + # Even though Moose re-exports things from Carp & + # Scalar::Util, we don't want to remove those at + # unimport time, because the importing package may + # have imported them explicitly ala + # + # use Carp qw( confess ); + # + # This is a hack. Since we can't know whether they + # really want to keep these subs or not, we err on the + # safe side and leave them in. + my $coderef_pkg; + ( $coderef_pkg, $name ) = Class::MOP::get_code_info($name); + + $is_removable{$name} = $coderef_pkg eq $package ? 1 : 0; } else { $sub = do { no strict 'refs'; \&{ $package . '::' . $name }; }; + + $is_removable{$name} = 1; } + $export_recorder->{$sub} = 1; + $exports{$name} = sub {$sub}; } + + for my $name ( keys %{ $args->{groups} } ) { + my $group = $args->{groups}{$name}; + + if (ref $group eq 'CODE') { + $groups{$name} = $class->_make_wrapped_group( + $package, + $group, + $export_recorder, + \%exports, + \%is_removable + ); + } + elsif (ref $group eq 'ARRAY') { + $groups{$name} = $group; + } + } } - return \%exports; + return ( \%exports, \%is_removable, \%groups ); } -{ - # 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, @_ ) } ); - }; - } +our $CALLER; - sub _make_import_sub { - shift; - my $exporter = shift; - my $exports_from = shift; - my $export_to_main = shift; - - return sub { - # 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, @_) = Moose::Exporter::_strip_traits(@_); - - # It's important to leave @_ as-is for the benefit of - # Sub::Exporter. - my $class = $_[0]; - - $CALLER = Moose::Exporter::_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; - - # we should never export to main - if ( $CALLER eq 'main' && ! $export_to_main ) { - warn - qq{$class does not export its sugar to the 'main' package.\n}; - return; - } +sub _make_wrapped_sub { + my $self = shift; + my $fq_name = shift; + my $sub = shift; + my $export_recorder = shift; - my $did_init_meta; - for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) { + # 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; - $c->init_meta( for_class => $CALLER ); - $did_init_meta = 1; - } + my $wrapper = $self->_curry_wrapper($sub, $fq_name, $caller); - if ($did_init_meta) { - _apply_meta_traits( $CALLER, $traits ); - } - elsif ( $traits && @{$traits} ) { - confess - "Cannot provide traits when $class does not have an init_meta() method"; - } + 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 _make_wrapped_group { + my $class = shift; + my $package = shift; # package calling use Moose::Exporter + my $sub = shift; + my $export_recorder = shift; + my $keywords = shift; + my $is_removable = shift; + + return sub { + my $caller = $CALLER; # package calling use PackageUsingMooseExporter -group => {args} + + # there are plenty of ways to deal with telling the code which + # package it lives in. the last arg (collector hashref) is + # otherwise unused, so we'll stick the original package in + # there and act like 'with_caller' by putting the calling + # package name as the first arg + $_[0] = $caller; + $_[3]{from} = $package; + + my $named_code = $sub->(@_); + $named_code ||= { }; + + # send invalid return value error up to Sub::Exporter + unless (ref $named_code eq 'HASH') { + return $named_code; + } + + for my $name (keys %$named_code) { + my $code = $named_code->{$name}; + + my $fq_name = $package . '::' . $name; + my $wrapper = $class->_curry_wrapper( + $code, + $fq_name, + $caller + ); + + my $sub = subname( $fq_name => $wrapper ); + $named_code->{$name} = $sub; + + # mark each coderef as ours + $keywords->{$name} = 1; + $is_removable->{$name} = 1; + $export_recorder->{$sub} = 1; + } + + return $named_code; + }; +} + +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 _late_curry_wrapper { + my $class = shift; + my $sub = shift; + my $fq_name = shift; + my $extra = shift; + my @ex_args = @_; + + my $wrapper = sub { + # resolve curried arguments at runtime via this closure + my @curry = ( $extra->( @ex_args ) ); + return $sub->(@curry, @_); + }; - goto $exporter; - }; + 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 $exporting_package = shift; + my $exporter = shift; + my $exports_from = shift; + my $export_to_main = shift; + + return sub { + + # 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; + + # we should never export to main + if ( $CALLER eq 'main' && !$export_to_main ) { + warn + qq{$class does not export its sugar to the 'main' package.\n}; + return; + } + + 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; + } + + 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" + ); + } + + goto $exporter; + }; } + sub _strip_traits { my $idx = first_index { $_ eq '-traits' } @_; - return ( undef, @_ ) unless $idx >= 0 && $#_ >= $idx + 1; + return ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1; my $traits = $_[ $idx + 1 ]; @@ -228,34 +439,42 @@ sub _strip_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 && @$traits; + return unless @{$traits}; - my $meta = $class->meta(); + my $meta = Class::MOP::class_of($class); my $type = ( split /::/, ref $meta )[-1] - or confess + or Moose->throw_error( 'Cannot determine metaclass type for trait application . Meta isa ' - . ref $meta; - - # We can only call does_role() on Moose::Meta::Class objects, and - # we can only do that on $meta->meta() if it has already had at - # least one trait applied to it. By default $meta->meta() returns - # a Class::MOP::Class object (not a Moose::Meta::Class). - my @traits = grep { - $meta->meta()->can('does_role') - ? not $meta->meta()->does_role($_) - : 1 + . ref $meta ); + + my @resolved_traits + = map { + ref $_ ? $_ : Moose::Util::resolve_metatrait_alias( $type => $_ ) } - map { Moose::Util::resolve_metatrait_alias( $type => $_ ) } @$traits; + @$traits; - return unless @traits; + return unless @resolved_traits; - Moose::Util::apply_all_roles_with_method( $meta, - 'apply_to_metaclass_instance', \@traits ); + Moose::Util::MetaRole::apply_metaclass_roles( + for_class => $class, + metaclass_roles => \@resolved_traits, + ); } sub _get_caller { @@ -272,40 +491,39 @@ sub _get_caller { sub _make_unimport_sub { shift; - my $sources = shift; - my $keywords = shift; + my $exporting_package = shift; + my $exports = shift; + my $is_removable = shift; + my $export_recorder = shift; return sub { - my $class = shift; my $caller = scalar caller(); Moose::Exporter->_remove_keywords( $caller, - [ $class, @{$sources} ], - $keywords + [ keys %{$exports} ], + $is_removable, + $export_recorder, ); }; } sub _remove_keywords { shift; - my $package = shift; - my $sources = shift; - my $keywords = shift; - - my %sources = map { $_ => 1 } @{$sources}; + my $package = shift; + my $keywords = shift; + my $is_removable = shift; + my $recorded_exports = shift; no strict 'refs'; - # loop through the keywords ... - foreach my $name ( @{$keywords} ) { + foreach my $name ( @{ $keywords } ) { + next unless $is_removable->{$name}; - # 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 unless $sources{$pkg_name}; + next unless $recorded_exports->{$sub}; # and if it is from us, then undef the slot delete ${ $package . '::' }{$name}; @@ -313,6 +531,11 @@ sub _remove_keywords { } } +sub import { + strict->import; + warnings->import; +} + 1; __END__ @@ -325,43 +548,55 @@ 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_caller => [ 'has_rw', 'sugar2' ], + as_is => [ 'sugar3', \&Some::Random::thing ], + also => 'Moose', ); + sub has_rw { + my ($caller, $name, %options) = @_; + Class::MOP::class_of($caller)->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 and +C methods for your module, based on a spec you provide. -It also lets your "stack" Moose-alike modules so you can export +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. +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: + +=over 4 -=head2 Moose::Exporter->build_import_methods(...) +=item B<< Moose::Exporter->setup_import_methods(...) >> When you call this method, C build custom C and C methods for your module. The import method will export @@ -373,7 +608,7 @@ exported functions. This method accepts the following parameters: -=over 4 +=over 8 =item * with_caller => [ ... ] @@ -389,17 +624,33 @@ 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>). +If you do export some other packages 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 +=item B<< Moose::Exporter->build_import_methods(...) >> + +Returns two code refs, one for import and one for unimport. + +Used by C. + +=back + =head1 IMPORTING AND init_meta If you want to set an alternative base object class or metaclass @@ -426,7 +677,9 @@ parameter passed as part of the import: use Moose -traits => [ 'My::Meta::Trait', 'My::Other::Trait' ]; -These traits will be applied to the caller's metaclass instance. These traits will be ignored +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 AUTHOR @@ -437,7 +690,7 @@ Stevan Little and others. =head1 COPYRIGHT AND LICENSE -Copyright 2008 by Infinity Interactive, Inc. +Copyright 2009 by Infinity Interactive, Inc. L