X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FExporter.pm;h=e4562776e69c1cd0d9ab007fd8a92275b219a147;hb=0f8380b0cdbda1e13ed7c456edd3f0d1c0315ec9;hp=7553a40f44fcf612f05b39a0f133289c6aa362a6;hpb=a7be0f8593e4e7b7f570f49027ee4f8f25d4d8bc;p=gitmo%2FMoose.git diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm index 7553a40..e456277 100644 --- a/lib/Moose/Exporter.pm +++ b/lib/Moose/Exporter.pm @@ -3,15 +3,15 @@ package Moose::Exporter; use strict; use warnings; -our $VERSION = '0.69'; +our $VERSION = '0.86'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; use Class::MOP; use List::MoreUtils qw( first_index uniq ); use Moose::Util::MetaRole; -use Sub::Exporter; - +use Sub::Exporter 0.980; +use Sub::Name qw(subname); my %EXPORT_SPEC; @@ -38,14 +38,14 @@ sub build_import_methods { my $export_recorder = {}; - my ( $exports, $is_removable ) + my ( $exports, $is_removable, $groups ) = $class->_make_sub_exporter_params( - [ $exporting_package, @exports_from ], $export_recorder ); + [ @exports_from, $exporting_package ], $export_recorder ); my $exporter = Sub::Exporter::build_exporter( { exports => $exports, - groups => { default => [':all'] } + groups => { default => [':all'], %$groups } } ); @@ -76,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 Moose::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}; @@ -102,6 +107,7 @@ sub _make_sub_exporter_params { my $packages = shift; my $export_recorder = shift; + my %groups; my %exports; my %is_removable; @@ -109,6 +115,15 @@ sub _make_sub_exporter_params { 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'; @@ -126,6 +141,23 @@ sub _make_sub_exporter_params { $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} } ) { my $sub; @@ -160,9 +192,26 @@ sub _make_sub_exporter_params { $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, \%is_removable ); + return ( \%exports, \%is_removable, \%groups ); } our $CALLER; @@ -182,9 +231,9 @@ sub _make_wrapped_sub { return sub { my $caller = $CALLER; - my $wrapper = $self->_make_wrapper($caller, $sub, $fq_name); + my $wrapper = $self->_curry_wrapper($sub, $fq_name, $caller); - my $sub = Class::MOP::subname($fq_name => $wrapper); + my $sub = subname($fq_name => $wrapper); $export_recorder->{$sub} = 1; @@ -192,13 +241,110 @@ sub _make_wrapped_sub { }; } -sub _make_wrapper { - shift; - my $caller = shift; +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, @_); + }; - return sub { $sub->($caller, @_) }; + 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 { @@ -221,6 +367,9 @@ sub _make_import_sub { my $traits; ( $traits, @_ ) = _strip_traits(@_); + my $metaclass; + ( $metaclass, @_ ) = _strip_metaclass(@_); + # Normally we could look at $_[0], but in some weird cases # (involving goto &Moose::import), $_[0] ends as something # else (like Squirrel). @@ -250,7 +399,7 @@ sub _make_import_sub { # Moose::Exporter, which in turn sets $CALLER, so we need # to protect against that. local $CALLER = $CALLER; - $c->init_meta( for_class => $CALLER ); + $c->init_meta( for_class => $CALLER, metaclass => $metaclass ); $did_init_meta = 1; } @@ -262,6 +411,7 @@ sub _make_import_sub { _apply_meta_traits( $CALLER, $traits ); } elsif ( @{$traits} ) { + require Moose; Moose->throw_error( "Cannot provide traits when $class does not have an init_meta() method" ); @@ -286,12 +436,24 @@ 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}; - my $meta = $class->meta(); + my $meta = Class::MOP::class_of($class); my $type = ( split /::/, ref $meta )[-1] or Moose->throw_error( @@ -364,6 +526,11 @@ sub _remove_keywords { } } +sub import { + strict->import; + warnings->import; +} + 1; __END__ @@ -376,9 +543,6 @@ Moose::Exporter - make an import() and unimport() just like Moose.pm package MyApp::Moose; - use strict; - use warnings; - use Moose (); use Moose::Exporter; @@ -390,7 +554,7 @@ Moose::Exporter - make an import() and unimport() just like Moose.pm sub has_rw { my ($caller, $name, %options) = @_; - Class::MOP::Class->initialize($caller)->add_attribute($name, + Class::MOP::class_of($caller)->add_attribute($name, is => 'rw', %options, ); @@ -409,19 +573,25 @@ Moose::Exporter - make an import() and unimport() just like Moose.pm =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 two public methods: -=head2 Moose::Exporter->setup_import_methods(...) +=over 4 + +=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 @@ -433,7 +603,7 @@ exported functions. This method accepts the following parameters: -=over 4 +=over 8 =item * with_caller => [ ... ] @@ -459,18 +629,23 @@ themselves, and therefore wants to keep it. 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 -=head2 Moose::Exporter->build_import_methods(...) +=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