X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FExporter.pm;h=e4562776e69c1cd0d9ab007fd8a92275b219a147;hb=0f8380b0cdbda1e13ed7c456edd3f0d1c0315ec9;hp=4862563dec7e3874202bfe517948ed7bd1613642;hpb=5bd4db9b7e1ab30af23aa908be646f5b52010fdf;p=gitmo%2FMoose.git diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm index 4862563..e456277 100644 --- a/lib/Moose/Exporter.pm +++ b/lib/Moose/Exporter.pm @@ -3,83 +3,693 @@ package Moose::Exporter; use strict; use warnings; +our $VERSION = '0.86'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + use Class::MOP; -use Sub::Exporter; +use List::MoreUtils qw( first_index uniq ); +use Moose::Util::MetaRole; +use Sub::Exporter 0.980; +use Sub::Name qw(subname); +my %EXPORT_SPEC; -sub get_caller{ - # 1 extra level because it's called by import so there's a layer of indirection - my $offset = 1; +sub setup_import_methods { + my ( $class, %args ) = @_; - return - (ref $_[1] && defined $_[1]->{into}) - ? $_[1]->{into} - : (ref $_[1] && defined $_[1]->{into_level}) - ? caller($offset + $_[1]->{into_level}) - : caller($offset); + 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, %args ) = @_; + + my $exporting_package = $args{exporting_package} ||= caller(); + + $EXPORT_SPEC{$exporting_package} = \%args; + + my @exports_from = $class->_follow_also( $exporting_package ); + + 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 } + } + ); + + # $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( $exporting_package, $exporter, + \@exports_from, $args{_export_to_main} ); + + my $unimport = $class->_make_unimport_sub( $exporting_package, $exports, + $is_removable, $export_recorder ); + + return ( $import, $unimport ) } -my %EXPORTED; -sub build_exporter { - my $class = shift; - my %args = @_; +{ + my $seen = {}; + + sub _follow_also { + my $class = shift; + my $exporting_package = shift; + + local %$seen = ( $exporting_package => 1 ); + + return uniq( _follow_also_real($exporting_package) ); + } + + sub _follow_also_real { + my $exporting_package = shift; + + 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}; + + return unless defined $also; + + my @also = ref $also ? @{$also} : $also; + + for my $package (@also) + { + die "Circular reference in also parameter to Moose::Exporter between $exporting_package and $package" + if $seen->{$package}; + + $seen->{$package} = 1; + } + + return @also, map { _follow_also_real($_) } @also; + } +} - my $exporting_pkg = caller(); +sub _make_sub_exporter_params { + my $class = shift; + my $packages = shift; + my $export_recorder = shift; + my %groups; my %exports; - for my $name ( @{ $args{with_caller} } ) { - my $sub = do { no strict 'refs'; \&{ $exporting_pkg . '::' . $name } }; + my %is_removable; + + 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( + $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, + ); - my $wrapped = Class::MOP::subname( - $exporting_pkg . '::' . $name => sub { $sub->( scalar caller(), @_ ) } ); + $is_removable{$name} = 1; + } + + for my $name ( @{ $args->{as_is} } ) { + my $sub; + + if ( ref $name ) { + $sub = $name; + + # 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; + } - $exports{$name} = sub { $wrapped }; + $export_recorder->{$sub} = 1; - push @{ $EXPORTED{$exporting_pkg} }, $name; + $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; + } + } } - for my $name ( @{ $args{as_is} } ) { - my $sub; + return ( \%exports, \%is_removable, \%groups ); +} + +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; - if ( ref $name ) { - $sub = $name; - $name = ( Class::MOP::get_code_info($name) )[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; } - else { - $sub = do { no strict 'refs'; \&{ $exporting_pkg . '::' . $name } }; - push @{ $EXPORTED{$exporting_pkg} }, $name; + 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; } - $exports{$name} = sub { $sub }; + 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; +} - return Sub::Exporter::build_exporter( - { - exports => \%exports, - groups => { default => [':all'] } +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, @_); + }; + + 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(@_); + + # 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 ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1; + + my $traits = $_[ $idx + 1 ]; + + 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 { Moose::Util::resolve_metatrait_alias( $type => $_ ) } + @$traits; + + return unless @resolved_traits; + + Moose::Util::MetaRole::apply_metaclass_roles( + for_class => $class, + metaclass_roles => \@resolved_traits, ); } -sub remove_keywords { - my $class = shift; - my %args = @_; +sub _get_caller { + # 1 extra level because it's called by import so there's a layer + # of indirection + my $offset = 1; + + return + ( ref $_[1] && defined $_[1]->{into} ) ? $_[1]->{into} + : ( ref $_[1] && defined $_[1]->{into_level} ) + ? caller( $offset + $_[1]->{into_level} ) + : caller($offset); +} + +sub _make_unimport_sub { + shift; + my $exporting_package = shift; + my $exports = shift; + my $is_removable = shift; + my $export_recorder = shift; + + return sub { + my $caller = scalar caller(); + Moose::Exporter->_remove_keywords( + $caller, + [ keys %{$exports} ], + $is_removable, + $export_recorder, + ); + }; +} + +sub _remove_keywords { + shift; + my $package = shift; + my $keywords = shift; + my $is_removable = shift; + my $recorded_exports = shift; no strict 'refs'; - for my $name ( @{ $EXPORTED{ $args{source} } } ) { - if ( defined &{ $args{from} . '::' . $name } ) { - my $keyword = \&{ $args{from} . '::' . $name }; + foreach my $name ( @{ $keywords } ) { + next unless $is_removable->{$name}; + + if ( defined &{ $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 ne $args{source}; + next unless $recorded_exports->{$sub}; # and if it is from us, then undef the slot - delete ${ $args{from} . '::' }{$name}; + delete ${ $package . '::' }{$name}; } } } +sub import { + strict->import; + warnings->import; +} + 1; + +__END__ + +=head1 NAME + +Moose::Exporter - make an import() and unimport() just like Moose.pm + +=head1 SYNOPSIS + + package MyApp::Moose; + + use Moose (); + use Moose::Exporter; + + 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'; + has_rw 'size'; + thing; + + no MyApp::Moose; + +=head1 DESCRIPTION + +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 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: + +=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 +the functions you specify, and you can also tell it to export +functions exported by some other module (like C). + +The C method cleans the callers namespace of all the +exported functions. + +This method accepts the following parameters: + +=over 8 + +=item * with_caller => [ ... ] + +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. + +=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>). + +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 +class, 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' ); + } + +=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 AUTHOR + +Dave Rolsky Eautarch@urth.orgE + +This is largely a reworking of code in Moose.pm originally written by +Stevan Little and others. + +=head1 COPYRIGHT AND LICENSE + +Copyright 2009 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut