X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=lib%2FMouse%2FExporter.pm;h=e44c2565f3c6960307907dca4cb5840bc1d095bf;hp=82b10f44d3d9502762777a60f14c9f5c9e227ac2;hb=57633577acaebd562d9bf8a798bb66f5840d88c7;hpb=2a7e621027a0980e8bcccd24ac3b3fe33b516a72 diff --git a/lib/Mouse/Exporter.pm b/lib/Mouse/Exporter.pm index 82b10f4..e44c256 100644 --- a/lib/Mouse/Exporter.pm +++ b/lib/Mouse/Exporter.pm @@ -6,15 +6,16 @@ use Carp qw(confess); my %SPEC; -use constant _strict_bits => strict::bits(qw(subs refs vars)); +my $strict_bits; +BEGIN{ $strict_bits = strict::bits(qw(subs refs vars)); } # it must be "require", because Mouse::Util depends on Mouse::Exporter, # which depends on Mouse::Util::import() require Mouse::Util; sub import{ - $^H |= _strict_bits; # strict->import; - ${^WARNING_BITS} = $warnings::Bits{all}; # warnings->import; + $^H |= $strict_bits; # strict->import; + ${^WARNING_BITS} |= $warnings::Bits{all}; # warnings->import; return; } @@ -26,20 +27,19 @@ sub setup_import_methods{ my($import, $unimport) = $class->build_import_methods(%args); - no strict 'refs'; - - *{$exporting_package . '::import'} = $import; - *{$exporting_package . '::unimport'} = $unimport; - - # for backward compatibility - *{$exporting_package . '::export_to_level'} = sub{ - my($package, $level, undef, @args) = @_; # the third argument is redundant - $package->import({ into_level => $level + 1 }, @args); - }; - *{$exporting_package . '::export'} = sub{ - my($package, $into, @args) = @_; - $package->import({ into => $into }, @args); - }; + Mouse::Util::install_subroutines($exporting_package, + import => $import, + unimport => $unimport, + + export_to_level => sub { + my($package, $level, undef, @args) = @_; # the third argument is redundant + $package->import({ into_level => $level + 1 }, @args); + }, + export => sub { + my($package, $into, @args) = @_; + $package->import({ into => $into }, @args); + }, + ); return; } @@ -67,66 +67,64 @@ sub build_import_methods{ @export_from = ($exporting_package); } - { - my %exports; - my @removables; - my @all; - - my @init_meta_methods; - - foreach my $package(@export_from){ - my $spec = $SPEC{$package} or next; - - if(my $as_is = $spec->{as_is}){ - foreach my $thingy (@{$as_is}){ - my($code_package, $code_name, $code); - - if(ref($thingy)){ - $code = $thingy; - ($code_package, $code_name) = Mouse::Util::get_code_info($code); - } - else{ - no strict 'refs'; - $code_package = $package; - $code_name = $thingy; - $code = \&{ $code_package . '::' . $code_name }; - } - - push @all, $code_name; - $exports{$code_name} = $code; - if($code_package eq $package){ - push @removables, $code_name; - } - } - } + my %exports; + my @removables; + my @all; + + my @init_meta_methods; + + foreach my $package(@export_from){ + my $spec = $SPEC{$package} or next; - if(my $init_meta = $package->can('init_meta')){ - if(!grep{ $_ == $init_meta } @init_meta_methods){ - push @init_meta_methods, $init_meta; + if(my $as_is = $spec->{as_is}){ + foreach my $thingy (@{$as_is}){ + my($code_package, $code_name, $code); + + if(ref($thingy)){ + $code = $thingy; + ($code_package, $code_name) = Mouse::Util::get_code_info($code); + } + else{ + $code_package = $package; + $code_name = $thingy; + no strict 'refs'; + $code = \&{ $code_package . '::' . $code_name }; + } + + push @all, $code_name; + $exports{$code_name} = $code; + if($code_package eq $package){ + push @removables, $code_name; } } } - $args{EXPORTS} = \%exports; - $args{REMOVABLES} = \@removables; - $args{groups}{all} ||= \@all; - - if(my $default_list = $args{groups}{default}){ - my %default; - foreach my $keyword(@{$default_list}){ - $default{$keyword} = $exports{$keyword} - || confess(qq{The $exporting_package package does not export "$keyword"}); + if(my $init_meta = $package->can('init_meta')){ + if(!grep{ $_ == $init_meta } @init_meta_methods){ + push @init_meta_methods, $init_meta; } - $args{DEFAULT} = \%default; - } - else{ - $args{groups}{default} ||= \@all; - $args{DEFAULT} = $args{EXPORTS}; } + } + $args{EXPORTS} = \%exports; + $args{REMOVABLES} = \@removables; - if(@init_meta_methods){ - $args{INIT_META} = \@init_meta_methods; + $args{groups}{all} ||= \@all; + + if(my $default_list = $args{groups}{default}){ + my %default; + foreach my $keyword(@{$default_list}){ + $default{$keyword} = $exports{$keyword} + || confess(qq{The $exporting_package package does not export "$keyword"}); } + $args{DEFAULT} = \%default; + } + else{ + $args{groups}{default} ||= \@all; + $args{DEFAULT} = $args{EXPORTS}; + } + + if(@init_meta_methods){ + $args{INIT_META} = \@init_meta_methods; } return (\&do_import, \&do_unimport); @@ -149,7 +147,7 @@ sub do_import { my $arg = shift @args; if($arg =~ s/^-//){ if($arg eq 'traits'){ - push @traits, @{shift(@args)}; + push @traits, ref($args[0]) ? @{shift(@args)} : shift(@args); } else { Mouse::Util::not_supported("-$arg"); @@ -165,45 +163,48 @@ sub do_import { } } - $^H |= _strict_bits; # strict->import; - ${^WARNING_BITS} = $warnings::Bits{all}; # warnings->import; + $^H |= $strict_bits; # strict->import; + ${^WARNING_BITS} |= $warnings::Bits{all}; # warnings->import; if($spec->{INIT_META}){ my $meta; foreach my $init_meta(@{$spec->{INIT_META}}){ - $meta = $into->$init_meta(for_class => $into); + $meta = $package->$init_meta(for_class => $into); } if(@traits){ my $type = (split /::/, ref $meta)[-1]; # e.g. "Class" for "My::Meta::Class" @traits = - map{ ref($_) ? $_ : Mouse::Util::resolve_metaclass_alias($type => $_, trait => 1) } - @traits; - - print "[@traits]\n"; + map{ + ref($_) ? $_ + : Mouse::Util::resolve_metaclass_alias($type => $_, trait => 1) + } @traits; - not_supported('-traits'); require Mouse::Util::MetaRole; - Mouse::Util::MetaRole::apply_metaclass_roles( - for_class => $into, - metaclass_roles => \@traits, + Mouse::Util::MetaRole::apply_metaroles( + for => $into, + Mouse::Util::is_a_metarole($into->meta) + ? (role_metaroles => { role => \@traits }) + : (class_metaroles => { class => \@traits }), ); } } + elsif(@traits){ + Carp::confess("Cannot provide traits when $package does not have an init_meta() method"); + } if(@exports){ + my @export_table; foreach my $keyword(@exports){ - no strict 'refs'; - *{$into.'::'.$keyword} = $spec->{EXPORTS}{$keyword} - || confess(qq{The $package package does not export "$keyword"}); + push @export_table, + $keyword => ($spec->{EXPORTS}{$keyword} + || confess(qq{The $package package does not export "$keyword"}) + ); } + Mouse::Util::install_subroutines($into, @export_table); } else{ - my $default = $spec->{DEFAULT}; - while(my($keyword, $code) = each %{$default}){ - no strict 'refs'; - *{$into.'::'.$keyword} = $code; - } + Mouse::Util::install_subroutines($into, %{$spec->{DEFAULT}}); } return; } @@ -223,6 +224,7 @@ sub do_unimport { }; for my $keyword (@{ $spec->{REMOVABLES} }) { + next if !exists $stash->{$keyword}; my $gv = \$stash->{$keyword}; if(ref($gv) eq 'GLOB' && *{$gv}{CODE} == $spec->{EXPORTS}{$keyword}){ # make sure it is from us delete $stash->{$keyword}; @@ -231,27 +233,24 @@ sub do_unimport { return; } -# 1 extra level because it's called by import so there's a layer -# of indirection -sub _LEVEL(){ 1 } - sub _get_caller_package { my($arg) = @_; + # We need one extra level because it's called by import so there's a layer + # of indirection if(ref $arg){ return defined($arg->{into}) ? $arg->{into} - : defined($arg->{into_level}) ? scalar caller(_LEVEL + $arg->{into_level}) - : scalar caller(_LEVEL); + : defined($arg->{into_level}) ? scalar caller(1 + $arg->{into_level}) + : scalar caller(1); } else{ - return scalar caller(_LEVEL); + return scalar caller(1); } } #sub _spec{ %SPEC } 1; - __END__ =head1 NAME @@ -260,46 +259,46 @@ Mouse::Exporter - make an import() and unimport() just like Mouse.pm =head1 VERSION -This document describes Mouse version 0.40 +This document describes Mouse version 0.50_03 =head1 SYNOPSIS - package MyApp::Mouse; - - use Mouse (); - use Mouse::Exporter; - - Mouse::Exporter->setup_import_methods( - as_is => [ 'has_rw', 'other_sugar', \&Some::Random::thing ], - also => 'Mouse', - ); - + package MyApp::Mouse; + + use Mouse (); + use Mouse::Exporter; + + Mouse::Exporter->setup_import_methods( + as_is => [ 'has_rw', 'other_sugar', \&Some::Random::thing ], + also => 'Mouse', + ); + sub has_rw { - my $meta = caller->meta; - my ( $name, %options ) = @_; - $meta->add_attribute( - $name, - is => 'rw', - %options, - ); - } - - # then later ... - package MyApp::User; - - use MyApp::Mouse; - - has 'name'; - has_rw 'size'; - thing; - + my $meta = caller->meta; + my ( $name, %options ) = @_; + $meta->add_attribute( + $name, + is => 'rw', + %options, + ); + } + + # then later ... + package MyApp::User; + + use MyApp::Mouse; + + has 'name'; + has_rw 'size'; + thing; + no MyApp::Mouse; =head1 DESCRIPTION -This module encapsulates the exporting of sugar functions in a -C-like manner. It does this by building custom C, -C methods for your module, based on a spec you provide. +This module encapsulates the exporting of sugar functions in a +C-like manner. It does this by building custom C, +C methods for your module, based on a spec you provide. Note that C does not provide the C option, but you can easily get the metaclass by C<< caller->meta >> as L shows.