From: gfx Date: Tue, 6 Oct 2009 06:11:38 +0000 (+0900) Subject: Work for Mouse::Exporter X-Git-Tag: 0.37_03~32 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=db9fc23783271f93e5a2bf15300f2f4a5284cc96;p=gitmo%2FMouse.git Work for Mouse::Exporter --- diff --git a/lib/Exporter.pm b/lib/Exporter.pm deleted file mode 100755 index a4bd24d..0000000 --- a/lib/Exporter.pm +++ /dev/null @@ -1,169 +0,0 @@ -package Mouse::Exporter; -use strict; -use warnings; - -use Carp 'confess'; -use Scalar::Util qw(looks_like_number); - -use Mouse::Util (); - -my %SPEC; - -sub setup_import_methods{ - my($class, %args) = @_; - - my $exporting_package = $args{exporting_package} ||= caller(); - - my $spec = $SPEC{$exporting_package} = {}; - - # canonicalize args - my @export_from = ($exporting_package); - { - my %seen = ($exporting_package => 1); - my @stack = ($exporting_package); - - while(my $current = shift @stack){ - push @export_from, $current; - - my $also = $args{also} or next; - unshift @stack, grep{ ++$seen{$_} == 1 } @{ $also }; - } - } - - print "[@export_from]\n"; - - my $import = sub{ _do_import ($spec, @_) }; - my $unimport = sub{ _do_unimport ($spec, @_) }; - my $init_meta = sub{ _do_init_meta($spec, @_) }; - - no strict 'refs'; - - *{$exporting_package . '::import'} = $import; - *{$exporting_package . '::unimport'} = $unimport; - *{$exporting_package . '::init_meta'} = $init_meta; - - return; -} - -sub init_meta { - shift; - my %args = @_; - - my $class = $args{for_class} - or confess("Cannot call init_meta without specifying a for_class"); - my $base_class = $args{base_class} || 'Mouse::Object'; - my $metaclass = $args{metaclass} || 'Mouse::Meta::Class'; - - confess("The Metaclass $metaclass must be a subclass of Mouse::Meta::Class.") - unless $metaclass->isa('Mouse::Meta::Class'); - - # make a subtype for each Mouse class - Mouse::Util::TypeConstraints::class_type($class) - unless Mouse::Util::TypeConstraints::find_type_constraint($class); - - my $meta = $metaclass->initialize($class); - - $meta->add_method(meta => sub{ - return $metaclass->initialize(ref($_[0]) || $_[0]); - }); - - $meta->superclasses($base_class) - unless $meta->superclasses; - - return $meta; -} - -sub _do_import { - my($class, $spec, @args) = @_; - - my $command; - - my @exports; - foreach my $arg(@args){ - if(ref $arg){ # e.g. use Mouse { into => $package }; - $command = $arg; - } - elsif($arg =~ s/^[-:]//){ - my $group = $spec->{group}{$arg} or confess(qq{group "$arg" is not exported by the $class module}); - push @exports, @{$group}; - } - else{ - push @exports, $arg; - } - } - - my $into = $command->{into} || caller(($command->{into_level} || 0) + 1); - - strict->import; - warnings->import; - - if($into eq 'main' && !$spec->{_not_export_to_main}){ - warn qq{$class does not export its sugar to the 'main' package.\n}; - return; - } - - $class->init_meta( - for_class => $into, - ); - - my $exports_ref = @exports ? \@exports : $spec->{default}; - - foreach my $keyword(@{$exports_ref}){ - no strict 'refs'; - *{$into.'::'.$keyword} = $spec->{exports}{$keyword} - or confess(qq{"$keyword" is not exported by the $class module}); - } - return; -} - -sub _do_unimport { - my($class, $spec) = @_; - - my $caller = caller; - - my $stash = do{ - no strict 'refs'; - \%{$caller . '::'} - }; - - for my $keyword (@{ $spec->{exports} }) { - my $code; - if(exists $spec->{is_removable}{$keyword} - && ($code = $caller->can($keyword)) - && (Mouse::Util::get_code_info($code))[0] eq __PACKAGE__){ - - delete $stash->{$keyword}; - } - } -} - -1; - -__END__ - -=head1 NAME - -Mouse - The Mouse Exporter - -=head1 SYNOPSIS - - package MouseX::Foo; - use Mouse::Exporter; - - Mouse::Exporter->setup_import_methods( - - ); - -=head1 DESCRIPTION - - -=head1 SEE ALSO - -L - -=head1 AUTHORS - -Goro Fuji (gfx) C<< >> - -=cut - diff --git a/lib/Mouse/Exporter.pm b/lib/Mouse/Exporter.pm new file mode 100644 index 0000000..f60c4e9 --- /dev/null +++ b/lib/Mouse/Exporter.pm @@ -0,0 +1,214 @@ +package Mouse::Exporter; +use strict; +use warnings; + +use Carp qw(confess); + +use Mouse::Util qw(get_code_info); + +my %SPEC; + +sub setup_import_methods{ + my($class, %args) = @_; + + my $exporting_package = $args{exporting_package} ||= caller(); + + $SPEC{$exporting_package} = \%args; + + # canonicalize args + my @export_from; + if($args{also}){ + my %seen; + my @stack = ($exporting_package); + + while(my $current = shift @stack){ + push @export_from, $current; + + my $also = $SPEC{$current}{also} or next; + push @stack, grep{ !$seen{$_}++ } @{ $also }; + } + } + else{ + @export_from = ($exporting_package); + } + + { + my %exports; + my @removables; + + foreach my $package(@export_from){ + my $spec = $SPEC{$package} or next; + + if(my $as_is = $spec->{as_is}){ + foreach my $thingy (@{$as_is}){ + my($name, $code); + + if(ref($thingy)){ + my $code_package; + $code = $thingy; + ($code_package, $name) = get_code_info($code); + } + else{ + no strict 'refs'; + $name = $thingy; + $code = \&{ $package . '::' . $name }; + } + + $exports{$name} = $code; + push @removables, $name; + } + } + } + $args{EXPORTS} = \%exports; + $args{REMOVABLES} = \@removables; + + $args{group}{default} ||= \@removables; + $args{group}{all} ||= \@removables; + } + + no strict 'refs'; + + *{$exporting_package . '::import'} = \&do_import; + *{$exporting_package . '::unimport'} = \&do_unimport; + + if(!defined &{$exporting_package . '::init_meta'}){ + *{$exporting_package . '::init_meta'} = \&do_init_meta; + } + return; +} + +# the entity of general init_meta() +sub do_init_meta { + my($class, %args) = @_; + + my $spec = $SPEC{$class} + or confess("The package $class does not use Mouse::Exporter"); + + my $for_class = $args{for_class} + or confess("Cannot call init_meta without specifying a for_class"); + + my $base_class = $args{base_class} || 'Mouse::Object'; + my $metaclass = $args{metaclass} || 'Mouse::Meta::Class'; + + my $meta = $metaclass->initialize($for_class); + + $meta->add_method(meta => sub{ + $metaclass->initialize(ref($_[0]) || $_[0]); + }); + + $meta->superclasses($base_class) + unless $meta->superclasses; + + return $meta; +} + +# the entity of general import() +sub do_import { + my($class, @args) = @_; + + my $spec = $SPEC{$class} + or confess("The package $class does not use Mouse::Exporter"); + + my $into = _get_caller_package(ref($args[0]) ? shift @args : undef); + + my @exports; + foreach my $arg(@args){ + if($arg =~ s/^[-:]//){ + my $group = $spec->{group}{$arg} or confess(qq{group "$arg" is not exported by the $class module}); + push @exports, @{$group}; + } + else{ + push @exports, $arg; + } + } + + strict->import; + warnings->import; + + if($into eq 'main' && !$spec->{_not_export_to_main}){ + warn qq{$class does not export its sugar to the 'main' package.\n}; + return; + } + + if($class->can('init_meta')){ + my $meta = $class->init_meta( + for_class => $into, + ); + + # TODO: process -metaclass and -traits + # ... + } + + + my $exports_ref = @exports ? \@exports : $spec->{group}{default}; + + foreach my $keyword(@{$exports_ref}){ + no strict 'refs'; + *{$into.'::'.$keyword} = $spec->{EXPORTS}{$keyword} + or confess(qq{"$keyword" is not exported by the $class module}); + } + return; +} + +# the entity of general unimport() +sub do_unimport { + my($class, $arg) = @_; + + my $spec = $SPEC{$class} + or confess("The package $class does not use Mouse::Exporter"); + + my $from = _get_caller_package($arg); + + my $stash = do{ + no strict 'refs'; + \%{$from . '::'} + }; + + for my $keyword (@{ $spec->{REMOVABLES} }) { + delete $stash->{$keyword}; + } + return; +} + +sub _get_caller_package { + my($arg) = @_; + + # 2 extra level because it's called by import so there's a layer + # of indirection + my $offset = 1; + + if(ref $arg){ + return defined($arg->{into}) ? $arg->{into} + : defined($arg->{into_level}) ? scalar caller($offset + $arg->{into_level}) + : scalar caller($offset); + } + else{ + return scalar caller($offset); + } +} + +1; + +__END__ + +=head1 NAME + +Mouse - The Mouse Exporter + +=head1 SYNOPSIS + + package MouseX::Foo; + use Mouse::Exporter; + + Mouse::Exporter->setup_import_methods( + + ); + +=head1 DESCRIPTION + + +=head1 SEE ALSO + +L + +=cut