From: gfx <gfuji@cpan.org>
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;hp=d054750b0b32ed7813c96fb9d7c3610ab3186529;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<Moose::Exporter>
-
-=head1 AUTHORS
-
-Goro Fuji (gfx) C<< <gfuji at cpan.org> >>
-
-=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<Moose::Exporter>
+
+=cut