X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FExporter.pm;h=961d172ce4186194db2c636d6cfe160673915bcd;hb=e2a758ad2cda3f25747bd9692a46c921cad45f34;hp=14ed924ee25dc21f3153fad4d71245e1b4606802;hpb=92d8204181e20d7b6a0144fca0a99095a7788ff4;p=gitmo%2FMoose.git diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm index 14ed924..961d172 100644 --- a/lib/Moose/Exporter.pm +++ b/lib/Moose/Exporter.pm @@ -3,13 +3,11 @@ package Moose::Exporter; use strict; use warnings; -our $VERSION = '0.87'; -$VERSION = eval $VERSION; -our $AUTHORITY = 'cpan:STEVAN'; - +use Class::Load qw(is_class_loaded); use Class::MOP; use List::MoreUtils qw( first_index uniq ); use Moose::Util::MetaRole; +use Scalar::Util qw(reftype); use Sub::Exporter 0.980; use Sub::Name qw(subname); @@ -18,200 +16,311 @@ 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); + $args{exporting_package} ||= caller(); - no strict 'refs'; - *{ $exporting_package . '::import' } = $import; - *{ $exporting_package . '::unimport' } = $unimport; + $class->build_import_methods( + %args, + install => [qw(import unimport init_meta)] + ); } +# A reminder to intrepid Moose hackers +# there may be more than one level of exporter +# don't make doy cry. -- perigrin + sub build_import_methods { my ( $class, %args ) = @_; my $exporting_package = $args{exporting_package} ||= caller(); + my $meta_lookup = $args{meta_lookup} || sub { Class::MOP::class_of(shift) }; + $EXPORT_SPEC{$exporting_package} = \%args; - my @exports_from = $class->_follow_also( $exporting_package ); + my @exports_from = $class->_follow_also($exporting_package); my $export_recorder = {}; + my $is_reexport = {}; + + my $exports = $class->_make_sub_exporter_params( + [ $exporting_package, @exports_from ], + $export_recorder, + $is_reexport, + $args{meta_lookup}, # so that we don't pass through the default + ); + + my $exporter = $class->_make_exporter( + $exports, + $is_reexport, + $meta_lookup, + ); + + my %methods; + $methods{import} = $class->_make_import_sub( + $exporting_package, + $exporter, + \@exports_from, + $is_reexport, + $meta_lookup, + ); + + $methods{unimport} = $class->_make_unimport_sub( + $exporting_package, + $exports, + $export_recorder, + $is_reexport, + $meta_lookup, + ); + + $methods{init_meta} = $class->_make_init_meta( + $exporting_package, + \%args, + $meta_lookup, + ); + + 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} ); + } + + return ( $methods{import}, $methods{unimport}, $methods{init_meta} ); +} - my ( $exports, $is_removable, $groups ) - = $class->_make_sub_exporter_params( - [ @exports_from, $exporting_package ], $export_recorder ); +sub _make_exporter { + my ($class, $exports, $is_reexport, $meta_lookup) = @_; - my $exporter = Sub::Exporter::build_exporter( + return Sub::Exporter::build_exporter( { - exports => $exports, - groups => { default => [':all'], %$groups } + exports => $exports, + groups => { default => [':all'] }, + installer => sub { + my ($arg, $to_export) = @_; + my $meta = $meta_lookup->($arg->{into}); + + goto &Sub::Exporter::default_installer unless $meta; + + # don't overwrite existing symbols with our magically flagged + # version of it if we would install the same sub that's already + # in the importer + + my @filtered_to_export; + my %installed; + for (my $i = 0; $i < @{ $to_export }; $i += 2) { + my ($as, $cv) = @{ $to_export }[$i, $i + 1]; + + next if !ref($as) + && $meta->has_package_symbol('&' . $as) + && $meta->get_package_symbol('&' . $as) == $cv; + + push @filtered_to_export, $as, $cv; + $installed{$as} = 1 unless ref $as; + } + + Sub::Exporter::default_installer($arg, \@filtered_to_export); + + for my $name ( keys %{$is_reexport} ) { + no strict 'refs'; + no warnings 'once'; + next unless exists $installed{$name}; + _flag_as_reexport( \*{ join q{::}, $arg->{into}, $name } ); + } + }, } ); +} - # $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} ); +sub _follow_also { + my $class = shift; + my $exporting_package = shift; - my $unimport = $class->_make_unimport_sub( $exporting_package, $exports, - $is_removable, $export_recorder ); + _die_if_cycle_found_in_also_list_for_package($exporting_package); - return ( $import, $unimport ) + return uniq( _follow_also_real($exporting_package) ); } -{ - my $seen = {}; +sub _follow_also_real { + my $exporting_package = shift; + my @also = _also_list_for_package($exporting_package); + + return map { $_, _follow_also_real($_) } @also; +} - sub _follow_also { - my $class = shift; - my $exporting_package = shift; +sub _also_list_for_package { + my $package = shift; - local %$seen = ( $exporting_package => 1 ); + if ( !exists $EXPORT_SPEC{$package} ) { + my $loaded = is_class_loaded($package); - return uniq( _follow_also_real($exporting_package) ); + die "Package in also ($package) does not seem to " + . "use Moose::Exporter" + . ( $loaded ? "" : " (is it loaded?)" ); } - sub _follow_also_real { - my $exporting_package = shift; + my $also = $EXPORT_SPEC{$package}{also}; - if (!exists $EXPORT_SPEC{$exporting_package}) { - my $loaded = Class::MOP::is_class_loaded($exporting_package); + return unless defined $also; - die "Package in also ($exporting_package) does not seem to " - . "use Moose::Exporter" - . ($loaded ? "" : " (is it loaded?)"); - } + return ref $also ? @$also : $also; +} - my $also = $EXPORT_SPEC{$exporting_package}{also}; +# this is no Tarjan algorithm, but for the list sizes expected, +# brute force will probably be fine (and more maintainable) +sub _die_if_cycle_found_in_also_list_for_package { + my $package = shift; + _die_if_also_list_cycles_back_to_existing_stack( + [ _also_list_for_package($package) ], + [$package], + ); +} - return unless defined $also; +sub _die_if_also_list_cycles_back_to_existing_stack { + my ( $also_list, $existing_stack ) = @_; - my @also = ref $also ? @{$also} : $also; + return unless @$also_list && @$existing_stack; - for my $package (@also) - { - die "Circular reference in also parameter to Moose::Exporter between $exporting_package and $package" - if $seen->{$package}; + for my $also_member (@$also_list) { + for my $stack_member (@$existing_stack) { + next unless $also_member eq $stack_member; - $seen->{$package} = 1; + die + "Circular reference in 'also' parameter to Moose::Exporter between " + . join( + ', ', + @$existing_stack + ) . " and $also_member"; } - return @also, map { _follow_also_real($_) } @also; + _die_if_also_list_cycles_back_to_existing_stack( + [ _also_list_for_package($also_member) ], + [ $also_member, @$existing_stack ], + ); + } +} + +sub _parse_trait_aliases { + my $class = shift; + my ($package, $aliases) = @_; + + my @ret; + for my $alias (@$aliases) { + my $name; + if (ref($alias)) { + reftype($alias) eq 'ARRAY' + or Moose->throw_error(reftype($alias) . " references are not " + . "valid arguments to the 'trait_aliases' " + . "option"); + + ($alias, $name) = @$alias; + } + else { + ($name = $alias) =~ s/.*:://; + } + push @ret, subname "${package}::${name}" => sub () { $alias }; } + + return @ret; } sub _make_sub_exporter_params { - my $class = shift; - my $packages = shift; - my $export_recorder = shift; + my $class = shift; + my $packages = shift; + my $export_recorder = shift; + my $is_reexport = shift; + my $meta_lookup_override = shift; - my %groups; my %exports; - my %is_removable; + my $current_meta_lookup; 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} || {} } - ]; + $current_meta_lookup = $meta_lookup_override || $args->{meta_lookup}; + $meta_lookup_override = $current_meta_lookup; - for my $name ( @{ $args->{with_caller} } ) { - my $sub = do { - no strict 'refs'; - \&{ $package . '::' . $name }; - }; + my $meta_lookup = $current_meta_lookup + || sub { Class::MOP::class_of(shift) }; + + 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( + $exports{$name} = $class->_make_wrapped_sub_with_meta( $fq_name, $sub, $export_recorder, - ); - - $is_removable{$name} = 1; + $meta_lookup, + ) unless exists $exports{$name}; } - for my $name ( @{ $args->{with_meta} } ) { - my $sub = do { - no strict 'refs'; - \&{ $package . '::' . $name }; - }; + for my $name ( @{ $args->{with_caller} } ) { + my $sub = $class->_sub_from_package( $package, $name ) + or next; my $fq_name = $package . '::' . $name; - $exports{$name} = $class->_make_wrapped_sub_with_meta( + $exports{$name} = $class->_make_wrapped_sub( $fq_name, $sub, $export_recorder, - ); - - $is_removable{$name} = 1; + ) unless exists $exports{$name}; } - for my $name ( @{ $args->{as_is} } ) { - my $sub; + my @extra_exports = $class->_parse_trait_aliases( + $package, $args->{trait_aliases}, + ); + for my $name ( @{ $args->{as_is} }, @extra_exports ) { + my ( $sub, $coderef_name ); 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. + $sub = $name; + my $coderef_pkg; - ( $coderef_pkg, $name ) = Class::MOP::get_code_info($name); + ( $coderef_pkg, $coderef_name ) + = Class::MOP::get_code_info($name); - $is_removable{$name} = $coderef_pkg eq $package ? 1 : 0; + 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; - $is_removable{$name} = 1; + $coderef_name = $name; } $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; - } + $exports{$coderef_name} = sub { $sub } + unless exists $exports{$coderef_name}; } } - return ( \%exports, \%is_removable, \%groups ); + return \%exports; +} + +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; @@ -231,9 +340,9 @@ sub _make_wrapped_sub { return sub { my $caller = $CALLER; - my $wrapper = $self->_curry_wrapper($sub, $fq_name, $caller); + my $wrapper = $self->_curry_wrapper( $sub, $fq_name, $caller ); - my $sub = subname($fq_name => $wrapper); + my $sub = subname( $fq_name => $wrapper ); $export_recorder->{$sub} = 1; @@ -246,14 +355,17 @@ sub _make_wrapped_sub_with_meta { my $fq_name = shift; my $sub = shift; my $export_recorder = shift; + my $meta_lookup = shift; return sub { my $caller = $CALLER; - my $wrapper = $self->_late_curry_wrapper($sub, $fq_name, - sub { Class::MOP::class_of(shift) } => $caller); + my $wrapper = $self->_late_curry_wrapper( + $sub, $fq_name, + $meta_lookup => $caller + ); - my $sub = subname($fq_name => $wrapper); + my $sub = subname( $fq_name => $wrapper ); $export_recorder->{$sub} = 1; @@ -261,67 +373,18 @@ sub _make_wrapped_sub_with_meta { }; } -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) { + 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); + &Scalar::Util::set_prototype( $wrapper, $proto ); } return $wrapper; } @@ -334,15 +397,17 @@ sub _late_curry_wrapper { my @ex_args = @_; my $wrapper = sub { + # resolve curried arguments at runtime via this closure - my @curry = ( $extra->( @ex_args ) ); - return $sub->(@curry, @_); + my @curry = ( $extra->(@ex_args) ); + return $sub->( @curry, @_ ); }; - if (my $proto = prototype $sub) { + 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); + &Scalar::Util::set_prototype( $wrapper, $proto ); } return $wrapper; } @@ -352,7 +417,8 @@ sub _make_import_sub { my $exporting_package = shift; my $exporter = shift; my $exports_from = shift; - my $export_to_main = shift; + my $is_reexport = shift; + my $meta_lookup = shift; return sub { @@ -369,6 +435,12 @@ sub _make_import_sub { my $metaclass; ( $metaclass, @_ ) = _strip_metaclass(@_); + $metaclass + = Moose::Util::resolve_metaclass_alias( 'Class' => $metaclass ) + if defined $metaclass && length $metaclass; + + my $meta_name; + ( $meta_name, @_ ) = _strip_meta_name(@_); # Normally we could look at $_[0], but in some weird cases # (involving goto &Moose::import), $_[0] ends as something @@ -386,29 +458,40 @@ sub _make_import_sub { 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 ); + $c->init_meta( + for_class => $CALLER, + metaclass => $metaclass, + meta_name => $meta_name, + ); $did_init_meta = 1; } + { + # The metaroles 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_metaroles( + $CALLER, + [$class, @$exports_from], + $meta_lookup + ); + } + 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 ); + _apply_meta_traits( $CALLER, $traits, $meta_lookup ); } elsif ( @{$traits} ) { require Moose; @@ -417,13 +500,21 @@ sub _make_import_sub { ); } - goto $exporter; + 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 ); }; } - sub _strip_traits { - my $idx = first_index { $_ eq '-traits' } @_; + my $idx = first_index { ( $_ || '' ) eq '-traits' } @_; return ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1; @@ -431,13 +522,13 @@ sub _strip_traits { splice @_, $idx, 2; - $traits = [ $traits ] unless ref $traits; + $traits = [$traits] unless ref $traits; return ( $traits, @_ ); } sub _strip_metaclass { - my $idx = first_index { $_ eq '-metaclass' } @_; + my $idx = first_index { ( $_ || '' ) eq '-metaclass' } @_; return ( undef, @_ ) unless $idx >= 0 && $#_ >= $idx + 1; @@ -448,31 +539,137 @@ sub _strip_metaclass { return ( $metaclass, @_ ); } +sub _strip_meta_name { + my $idx = first_index { ( $_ || '' ) eq '-meta_name' } @_; + + return ( 'meta', @_ ) unless $idx >= 0 && $#_ >= $idx + 1; + + my $meta_name = $_[ $idx + 1 ]; + + splice @_, $idx, 2; + + return ( $meta_name, @_ ); +} + +sub _apply_metaroles { + my ($class, $exports_from, $meta_lookup) = @_; + + my $metaroles = _collect_metaroles($exports_from); + my $base_class_roles = delete $metaroles->{base_class_roles}; + + my $meta = $meta_lookup->($class); + # for instance, Moose.pm uses Moose::Util::TypeConstraints + return unless $meta; + + Moose::Util::MetaRole::apply_metaroles( + for => $meta, + %$metaroles, + ) if keys %$metaroles; + + Moose::Util::MetaRole::apply_base_class_roles( + for => $meta, + roles => $base_class_roles, + ) if $meta->isa('Class::MOP::Class') + && $base_class_roles && @$base_class_roles; +} + +sub _collect_metaroles { + my ($exports_from) = @_; + + my @old_style_role_types = map { "${_}_roles" } qw( + metaclass + attribute_metaclass + method_metaclass + wrapped_method_metaclass + instance_metaclass + constructor_class + destructor_class + error_class + ); + + my %class_metaroles; + my %role_metaroles; + my @base_class_roles; + my %old_style_roles; + + for my $exporter (@$exports_from) { + my $data = $EXPORT_SPEC{$exporter}; + + if (exists $data->{class_metaroles}) { + for my $type (keys %{ $data->{class_metaroles} }) { + push @{ $class_metaroles{$type} ||= [] }, + @{ $data->{class_metaroles}{$type} }; + } + } + + if (exists $data->{role_metaroles}) { + for my $type (keys %{ $data->{role_metaroles} }) { + push @{ $role_metaroles{$type} ||= [] }, + @{ $data->{role_metaroles}{$type} }; + } + } + + if (exists $data->{base_class_roles}) { + push @base_class_roles, @{ $data->{base_class_roles} }; + } + + for my $type (@old_style_role_types) { + if (exists $data->{$type}) { + push @{ $old_style_roles{$type} ||= [] }, + @{ $data->{$type} }; + } + } + } + + return { + (keys(%class_metaroles) + ? (class_metaroles => \%class_metaroles) + : ()), + (keys(%role_metaroles) + ? (role_metaroles => \%role_metaroles) + : ()), + (@base_class_roles + ? (base_class_roles => \@base_class_roles) + : ()), + %old_style_roles, + }; +} + sub _apply_meta_traits { - my ( $class, $traits ) = @_; + my ( $class, $traits, $meta_lookup ) = @_; return unless @{$traits}; - my $meta = Class::MOP::class_of($class); + my $meta = $meta_lookup->($class); - my $type = ( split /::/, ref $meta )[-1] - or Moose->throw_error( - 'Cannot determine metaclass type for trait application . Meta isa ' - . ref $meta ); + my $type = $meta->isa('Moose::Meta::Role') ? 'Trait' + : $meta->isa('Class::MOP::Class') ? 'Class' + : 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; + my @resolved_traits = map { + ref $_ + ? $_ + : Moose::Util::resolve_metatrait_alias( $type => $_ ) + } @$traits; return unless @resolved_traits; - Moose::Util::MetaRole::apply_metaclass_roles( - for_class => $class, - metaclass_roles => \@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; @@ -488,16 +685,17 @@ sub _make_unimport_sub { shift; my $exporting_package = shift; my $exports = shift; - my $is_removable = shift; my $export_recorder = shift; + my $is_reexport = shift; + my $meta_lookup = shift; return sub { my $caller = scalar caller(); Moose::Exporter->_remove_keywords( $caller, [ keys %{$exports} ], - $is_removable, $export_recorder, + $is_reexport, ); }; } @@ -506,26 +704,74 @@ sub _remove_keywords { shift; my $package = shift; my $keywords = shift; - my $is_removable = shift; my $recorded_exports = shift; + my $is_reexport = shift; no strict 'refs'; - foreach my $name ( @{ $keywords } ) { - next unless $is_removable->{$name}; - + foreach my $name ( @{$keywords} ) { if ( defined &{ $package . '::' . $name } ) { my $sub = \&{ $package . '::' . $name }; # make sure it is from us 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}; } } } +# maintain this for now for backcompat +# make sure to return a sub to install in the same circumstances as previously +# but this functionality now happens at the end of ->import +sub _make_init_meta { + shift; + my $class = shift; + my $args = shift; + my $meta_lookup = 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 %opts = @_; + $meta_lookup->($opts{for_class}); + }; +} + sub import { strict->import; warnings->import; @@ -533,11 +779,9 @@ sub import { 1; -__END__ - -=head1 NAME +# ABSTRACT: make an import() and unimport() just like Moose.pm -Moose::Exporter - make an import() and unimport() just like Moose.pm +__END__ =head1 SYNOPSIS @@ -547,14 +791,15 @@ Moose::Exporter - make an import() and unimport() just like Moose.pm use Moose::Exporter; Moose::Exporter->setup_import_methods( - with_caller => [ 'has_rw', 'sugar2' ], - as_is => [ 'sugar3', \&Some::Random::thing ], - also => 'Moose', + with_meta => [ '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, + my ( $meta, $name, %options ) = @_; + $meta->add_attribute( + $name, is => 'rw', %options, ); @@ -577,9 +822,11 @@ 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. +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. To simplify writing exporter modules, C also imports C and C into your exporter module, as well as into @@ -593,54 +840,103 @@ This module provides two public 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 -the functions you specify, and you can also tell it to export -functions exported by some other module (like C). +When you call this method, C builds custom 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). If you pass any parameters +for L, the C method will also call +C and +C as needed, after making +sure the metaclass is initialized. + +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. -The C method cleans the callers namespace of all the -exported functions. +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 8 -=item * with_caller => [ ... ] +=item * with_meta => [ ... ] -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. +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. + +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>). + +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 * trait_aliases => [ ... ] -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. +This is a list of package names which should have shortened aliases exported, +similar to the functionality of L. Each element in the list can be +either a package name, in which case the export will be named as the last +namespace component of the package, or an arrayref, whose first element is the +package to alias to, and second element is the alias to export. =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 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. +=item * meta_lookup => sub { ... } + +This is a function which will be called to provide the metaclass +to be operated upon by the exporter. This is an advanced feature +intended for use by package generator modules in the vein of +L in order to simplify reusing sugar +from other modules that use C. This function is +used, for example, to select the metaclass to bind to functions +that are exported using the C option. + +This function will receive one parameter: the class name into which +the sugar is being exported. The default implementation is: + + sub { Class::MOP::class_of(shift) } + +Accordingly, this function is expected to return a metaclass. + =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 code refs, one for import and one for unimport. +Returns two code refs, one for C and one for C. + +Accepts the additional C option, which accepts an arrayref of method +names to install into your exporting package. The valid options are C +and C. Calling C is equivalent +to calling C with C<< install => [qw(import unimport)] >> +except that it doesn't also return the methods. + +The C method is built using L. This means that it can +take a hashref of the form C<< { into => $package } >> to specify the package +it operates on. Used by C. @@ -648,11 +944,14 @@ Used by C. =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. +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: @@ -676,20 +975,8 @@ 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 +=head1 BUGS -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +See L for details on reporting bugs. =cut