X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FExporter.pm;h=ed4d22005c8dd6a05c204be47b7b093cc210f669;hb=3eb89f709f04907580b508f821d6be2316fcb65f;hp=faebc2c74c35ca39782ef9c2a09bbb86db49d185;hpb=37e4fe9594de1209d5836eaee6eaacf995172066;p=gitmo%2FMoose.git diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm index faebc2c..ed4d220 100644 --- a/lib/Moose/Exporter.pm +++ b/lib/Moose/Exporter.pm @@ -3,7 +3,8 @@ package Moose::Exporter; use strict; use warnings; -our $VERSION = '0.89_01'; +our $VERSION = '1.01'; +our $XS_VERSION = $VERSION; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -13,6 +14,10 @@ use Moose::Util::MetaRole; use Sub::Exporter 0.980; use Sub::Name qw(subname); +use XSLoader; + +XSLoader::load( 'Moose', $XS_VERSION ); + my %EXPORT_SPEC; sub setup_import_methods { @@ -33,33 +38,43 @@ sub build_import_methods { $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, $is_removable, $groups ) - = $class->_make_sub_exporter_params( - [ @exports_from, $exporting_package ], $export_recorder ); + my $exports = $class->_make_sub_exporter_params( + [ @exports_from, $exporting_package ], + $export_recorder, + $is_reexport, + ); my $exporter = Sub::Exporter::build_exporter( { exports => $exports, - groups => { default => [':all'], %$groups } + groups => { default => [':all'] } } ); my %methods; - # $args{_export_to_main} exists for backwards compat, because - # Moose::Util::TypeConstraints did export to main (unlike Moose & - # Moose::Role). - $methods{import} = $class->_make_import_sub( $exporting_package, - $exporter, \@exports_from, $args{_export_to_main} ); + $methods{import} = $class->_make_import_sub( + $exporting_package, + $exporter, + \@exports_from, + $is_reexport + ); - $methods{unimport} = $class->_make_unimport_sub( $exporting_package, - $exports, $is_removable, $export_recorder ); + $methods{unimport} = $class->_make_unimport_sub( + $exporting_package, + $exports, + $export_recorder, + $is_reexport + ); - $methods{init_meta} = $class->_make_init_meta( $exporting_package, - \%args ); + $methods{init_meta} = $class->_make_init_meta( + $exporting_package, + \%args + ); my $package = Class::MOP::Package->initialize($exporting_package); for my $to_install ( @{ $args{install} || [] } ) { @@ -70,7 +85,7 @@ sub build_import_methods { $package->add_package_symbol( $symbol, $methods{$to_install} ); } - return ( $methods{import}, $methods{unimport}, $methods{init_meta} ) + return ( $methods{import}, $methods{unimport}, $methods{init_meta} ); } { @@ -88,12 +103,12 @@ sub build_import_methods { sub _follow_also_real { my $exporting_package = shift; - if (!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?)"); + . "use Moose::Exporter" + . ( $loaded ? "" : " (is it loaded?)" ); } my $also = $EXPORT_SPEC{$exporting_package}{also}; @@ -102,9 +117,9 @@ sub build_import_methods { my @also = ref $also ? @{$also} : $also; - for my $package (@also) - { - die "Circular reference in also parameter to Moose::Exporter between $exporting_package and $package" + for my $package (@also) { + die + "Circular reference in 'also' parameter to Moose::Exporter between $exporting_package and $package" if $seen->{$package}; $seen->{$package} = 1; @@ -115,115 +130,88 @@ sub build_import_methods { } 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 %groups; my %exports; - 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 }; - }; + 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; } - 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; } for my $name ( @{ $args->{as_is} } ) { - my $sub; + 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}; } } - 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; @@ -243,9 +231,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; @@ -262,10 +250,12 @@ sub _make_wrapped_sub_with_meta { 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, + sub { Class::MOP::class_of(shift) } => $caller + ); - my $sub = subname($fq_name => $wrapper); + my $sub = subname( $fq_name => $wrapper ); $export_recorder->{$sub} = 1; @@ -273,67 +263,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; } @@ -346,15 +287,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; } @@ -364,7 +307,7 @@ sub _make_import_sub { my $exporting_package = shift; my $exporter = shift; my $exports_from = shift; - my $export_to_main = shift; + my $is_reexport = shift; return sub { @@ -381,9 +324,9 @@ sub _make_import_sub { my $metaclass; ( $metaclass, @_ ) = _strip_metaclass(@_); - $metaclass = Moose::Util::resolve_metaclass_alias( - 'Class' => $metaclass - ) if defined $metaclass && length $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 @@ -401,15 +344,9 @@ 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. @@ -419,6 +356,7 @@ sub _make_import_sub { } 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. @@ -432,11 +370,25 @@ 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 ); + + for my $name ( keys %{$is_reexport} ) { + no strict 'refs'; + no warnings 'once'; + _flag_as_reexport( \*{ join q{::}, $CALLER, $name } ); + } }; } - sub _strip_traits { my $idx = first_index { $_ eq '-traits' } @_; @@ -446,7 +398,7 @@ sub _strip_traits { splice @_, $idx, 2; - $traits = [ $traits ] unless ref $traits; + $traits = [$traits] unless ref $traits; return ( $traits, @_ ); } @@ -473,23 +425,30 @@ sub _apply_meta_traits { my $type = ( split /::/, ref $meta )[-1] or Moose->throw_error( 'Cannot determine metaclass type for trait application . Meta isa ' - . ref $meta ); + . ref $meta ); - my @resolved_traits - = map { - ref $_ ? $_ : 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; @@ -505,16 +464,16 @@ sub _make_unimport_sub { shift; my $exporting_package = shift; my $exports = shift; - my $is_removable = shift; my $export_recorder = shift; + my $is_reexport = shift; return sub { my $caller = scalar caller(); Moose::Exporter->_remove_keywords( $caller, [ keys %{$exports} ], - $is_removable, $export_recorder, + $is_reexport, ); }; } @@ -523,20 +482,25 @@ 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}; } @@ -548,10 +512,11 @@ sub _make_init_meta { my $class = shift; my $args = shift; - my %metaclass_roles; + my %old_style_roles; for my $role ( map {"${_}_roles"} - qw(metaclass + qw( + metaclass attribute_metaclass method_metaclass wrapped_method_metaclass @@ -559,18 +524,20 @@ sub _make_init_meta { constructor_class destructor_class error_class - application_to_class_class - application_to_role_class - application_to_instance_class) + ) ) { - $metaclass_roles{$role} = $args->{$role} if exists $args->{$role}; + $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}; - return unless %metaclass_roles || %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; @@ -578,9 +545,10 @@ sub _make_init_meta { return unless Class::MOP::class_of( $options{for_class} ); - Moose::Util::MetaRole::apply_metaclass_roles( - for_class => $options{for_class}, - %metaclass_roles, + Moose::Util::MetaRole::apply_metaroles( + for => $options{for_class}, + %new_style_roles, + %old_style_roles, ); Moose::Util::MetaRole::apply_base_class_roles( @@ -615,14 +583,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, ); @@ -670,7 +639,9 @@ will export the functions you specify, and can also re-export functions exported by some other module (like C). The C method cleans the caller's namespace of all the exported -functions. +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. If you pass any parameters for L, this method will generate an C for you as well (see below for details). This @@ -685,12 +656,13 @@ This method accepts the following parameters: =over 8 -=item * with_caller => [ ... ] +=item * with_meta => [ ... ] This list of function I will be 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. +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 => [ ... ] @@ -708,7 +680,7 @@ 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 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. @@ -717,9 +689,9 @@ when C is called. =back -Any of the C<*_roles> options for -C and -C are also acceptable. +You can also provide parameters for C +and C. Specifically, valid parameters +are "class_metaroles", "role_metaroles", and "base_object_roles". =item B<< Moose::Exporter->build_import_methods(...) >> @@ -799,6 +771,10 @@ 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 BUGS + +See L for details on reporting bugs. + =head1 AUTHOR Dave Rolsky Eautarch@urth.orgE