X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FExporter.pm;h=6a4014d6824c70c7aa416caeb90cd83ceb242f64;hb=5ef36adde3d619733607b9f5f1136524a00848df;hp=980bee582aacb2eb4883509d6eb3b5faf81aaedb;hpb=722c9bcbe9633bbebe5b71773b8d8e574385b604;p=gitmo%2FMoose.git diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm index 980bee5..6a4014d 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.71'; +our $VERSION = '0.85'; $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( [ @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 => [ ... ] @@ -468,12 +638,14 @@ 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