From: Fuji, Goro <gfuji@cpan.org>
Date: Thu, 23 Sep 2010 13:14:57 +0000 (+0900)
Subject: Split role application to a module like Moose
X-Git-Tag: 0.71~24
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=823419c540f9e77090f31f11e04b14477c0372c4;hp=4cc4f8ed10b2e831b9917b94fdad6e4cdddf9997

Split role application to a module like Moose
---

diff --git a/Makefile.PL b/Makefile.PL
index 891bfa0..6b45f5e 100755
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -14,9 +14,6 @@ use inc::Module::Install 1.00;
 use Module::Install::XSUtil 0.30;
 use Module::Install::AuthorTests;
 
-system($^X, 'tool/generate-mouse-tiny.pl', 'lib/Mouse/Tiny.pm') == 0
-    or warn "Cannot generate Mouse::Tiny: $!";
-
 name     'Mouse';
 all_from 'lib/Mouse.pm';
 
@@ -74,6 +71,12 @@ author_tests 'xt';
 
 repository 'git://git.moose.perl.org/Mouse.git';
 
+system($^X, 'tool/generate-mouse-tiny.pl', 'lib/Mouse/Tiny.pm') == 0
+    or warn "Cannot generate Mouse::Tiny: $!";
+makemaker_args PL_FILES => {
+    'tool/generate-mouse-tiny.pl' => 'lib/Mouse/Tiny.pm',
+};
+
 if ($Module::Install::AUTHOR) {
     require 'lib/Mouse/Spec.pm'; # for the version
     my $require_version = Mouse::Spec->MooseVersion;
diff --git a/lib/Mouse/Meta/Attribute.pm b/lib/Mouse/Meta/Attribute.pm
index 706c4f0..9110900 100644
--- a/lib/Mouse/Meta/Attribute.pm
+++ b/lib/Mouse/Meta/Attribute.pm
@@ -340,13 +340,6 @@ sub _make_delegation_method {
         ->_generate_delegation($self, $handle, $method_to_call);
 }
 
-sub throw_error{
-    my $self = shift;
-
-    my $metaclass = (ref $self && $self->associated_class) || 'Mouse::Meta::Class';
-    $metaclass->throw_error(@_, depth => 1);
-}
-
 1;
 __END__
 
diff --git a/lib/Mouse/Meta/Module.pm b/lib/Mouse/Meta/Module.pm
index be07d80..7827799 100755
--- a/lib/Mouse/Meta/Module.pm
+++ b/lib/Mouse/Meta/Module.pm
@@ -309,19 +309,6 @@ sub DESTROY{
     return;
 }
 
-sub throw_error{
-    my($self, $message, %args) = @_;
-
-    local $Carp::CarpLevel  = $Carp::CarpLevel + 1 + ($args{depth} || 0);
-    local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though
-
-    if(exists $args{longmess} && !$args{longmess}){ # intentionaly longmess => 0
-        Carp::croak($message);
-    }
-    else{
-        Carp::confess($message);
-    }
-}
 
 1;
 __END__
diff --git a/lib/Mouse/Meta/Role.pm b/lib/Mouse/Meta/Role.pm
index eb383e9..fe6575e 100644
--- a/lib/Mouse/Meta/Role.pm
+++ b/lib/Mouse/Meta/Role.pm
@@ -64,193 +64,21 @@ sub add_attribute {
     return;
 }
 
-sub _check_required_methods{
-    my($role, $consumer, $args) = @_;
-
-    if($args->{_to} eq 'role'){
-        $consumer->add_required_methods($role->get_required_method_list);
-    }
-    else{ # to class or instance
-        my $consumer_class_name = $consumer->name;
-
-        my @missing;
-        foreach my $method_name(@{$role->{required_methods}}){
-            next if exists $args->{aliased_methods}{$method_name};
-            next if exists $role->{methods}{$method_name};
-            next if $consumer_class_name->can($method_name);
-
-            push @missing, $method_name;
-        }
-        if(@missing){
-            $role->throw_error(sprintf "'%s' requires the method%s %s to be implemented by '%s'",
-                $role->name,
-                (@missing == 1 ? '' : 's'), # method or methods
-                Mouse::Util::quoted_english_list(@missing),
-                $consumer_class_name);
-        }
-    }
-
-    return;
-}
-
-sub _apply_methods{
-    my($role, $consumer, $args) = @_;
-
-    my $alias    = $args->{-alias};
-    my $excludes = $args->{-excludes};
-
-    foreach my $method_name($role->get_method_list){
-        next if $method_name eq 'meta';
-
-        my $code = $role->get_method_body($method_name);
-
-        if(!exists $excludes->{$method_name}){
-            if(!$consumer->has_method($method_name)){
-                # The third argument $role is used in Role::Composite
-                $consumer->add_method($method_name => $code, $role);
-            }
-        }
-
-        if(exists $alias->{$method_name}){
-            my $dstname = $alias->{$method_name};
-
-            my $dstcode = $consumer->get_method_body($dstname);
-
-            if(defined($dstcode) && $dstcode != $code){
-                $role->throw_error("Cannot create a method alias if a local method of the same name exists");
-            }
-            else{
-                $consumer->add_method($dstname => $code, $role);
-            }
-        }
-    }
-
-    return;
-}
-
-sub _apply_attributes{
-    #my($role, $consumer, $args) = @_;
-    my($role, $consumer) = @_;
-
-    for my $attr_name ($role->get_attribute_list) {
-        next if $consumer->has_attribute($attr_name);
-
-        $consumer->add_attribute($attr_name => $role->get_attribute($attr_name));
-    }
-    return;
-}
-
-sub _apply_modifiers{
-    #my($role, $consumer, $args) = @_;
-    my($role, $consumer) = @_;
-
-
-    if(my $modifiers = $role->{override_method_modifiers}){
-        foreach my $method_name (keys %{$modifiers}){
-            $consumer->add_override_method_modifier($method_name => $modifiers->{$method_name});
-        }
-    }
-
-    for my $modifier_type (qw/before around after/) {
-        my $table = $role->{"${modifier_type}_method_modifiers"}
-            or next;
-
-        my $add_modifier = "add_${modifier_type}_method_modifier";
-
-        while(my($method_name, $modifiers) = each %{$table}){
-            foreach my $code(@{ $modifiers }){
-                next if $consumer->{"_applied_$modifier_type"}{$method_name, $code}++; # skip applied modifiers
-                $consumer->$add_modifier($method_name => $code);
-            }
-        }
-    }
-    return;
-}
-
-sub _append_roles{
-    #my($role, $consumer, $args) = @_;
-    my($role, $consumer) = @_;
-
-    my $roles = $consumer->{roles};
-
-    foreach my $r($role, @{$role->get_roles}){
-        if(!$consumer->does_role($r)){
-            push @{$roles}, $r;
-        }
-    }
-    return;
-}
 
 # Moose uses Application::ToInstance, Application::ToClass, Application::ToRole
 sub apply {
     my $self     = shift;
     my $consumer = shift;
 
-    my %args = (@_ == 1) ? %{ $_[0] } : @_;
-
-    my $instance;
-
-    if(Mouse::Util::is_a_metaclass($consumer)){  # Application::ToClass
-        $args{_to} = 'class';
-    }
-    elsif(Mouse::Util::is_a_metarole($consumer)){ # Application::ToRole
-        $args{_to} = 'role';
-    }
-    else{                                       # Appplication::ToInstance
-        $args{_to} = 'instance';
-        $instance  = $consumer;
-
-        $consumer = (Mouse::Util::class_of($instance) || 'Mouse::Meta::Class')
-            ->create_anon_class(
-                superclasses => [ref $instance],
-                cache        => 1,
-            );
-    }
-
-    if($args{alias} && !exists $args{-alias}){
-        $args{-alias} = $args{alias};
-    }
-    if($args{excludes} && !exists $args{-excludes}){
-        $args{-excludes} = $args{excludes};
-    }
-
-    $args{aliased_methods} = {};
-    if(my $alias = $args{-alias}){
-        @{$args{aliased_methods}}{ values %{$alias} } = ();
-    }
-
-    if(my $excludes = $args{-excludes}){
-        $args{-excludes} = {}; # replace with a hash ref
-        if(ref $excludes){
-            %{$args{-excludes}} = (map{ $_ => undef } @{$excludes});
-        }
-        else{
-            $args{-excludes}{$excludes} = undef;
-        }
-    }
-
-    $self->_check_required_methods($consumer, \%args);
-    $self->_apply_attributes($consumer, \%args);
-    $self->_apply_methods($consumer, \%args);
-    $self->_apply_modifiers($consumer, \%args);
-    $self->_append_roles($consumer, \%args);
-
-
-    if(defined $instance){ # Application::ToInstance
-        # rebless instance
-        bless $instance, $consumer->name;
-        $consumer->_initialize_object($instance, $instance, 1);
-    }
-
-    return;
+    require 'Mouse/Meta/Role/Application.pm';
+    return Mouse::Meta::Role::Application->new(@_)->apply($self, $consumer);
 }
 
 
 sub combine {
     my($self, @role_specs) = @_;
 
-    require 'Mouse/Meta/Role/Composite.pm'; # we don't want to create its namespace
-
+    require 'Mouse/Meta/Role/Composite.pm';
     my $composite = Mouse::Meta::Role::Composite->create_anon_role();
 
     foreach my $role_spec (@role_specs) {
diff --git a/lib/Mouse/Meta/Role/Application.pm b/lib/Mouse/Meta/Role/Application.pm
new file mode 100644
index 0000000..07efede
--- /dev/null
+++ b/lib/Mouse/Meta/Role/Application.pm
@@ -0,0 +1,216 @@
+package Mouse::Meta::Role::Application;
+use Mouse::Util qw(:meta);
+
+sub new {
+    my $class = shift;
+    my $args = $class->Mouse::Object::BUILDARGS(@_);
+
+    if(exists $args->{exclude} or exists $args->{alias}) {
+        warnings::warnif(deprecated =>
+              'The alias and excludes options for role application have been'
+            . ' renamed -alias and -exclude');
+
+        if($args->{alias} && !exists $args->{-alias}){
+            $args->{-alias} = $args->{alias};
+        }
+        if($args->{excludes} && !exists $args->{-excludes}){
+            $args->{-excludes} = $args->{excludes};
+        }
+    }
+
+    $args->{aliased_methods} = {};
+    if(my $alias = $args->{-alias}){
+        @{$args->{aliased_methods}}{ values %{$alias} } = ();
+    }
+
+    if(my $excludes = $args->{-excludes}){
+        $args->{-excludes} = {}; # replace with a hash ref
+        if(ref $excludes){
+            %{$args->{-excludes}} = (map{ $_ => undef } @{$excludes});
+        }
+        else{
+            $args->{-excludes}{$excludes} = undef;
+        }
+    }
+    my $self = bless $args, $class;
+    if($class ne __PACKAGE__){
+        $self->meta->_initialize_object($self, $args);
+    }
+    return $self;
+}
+
+sub apply {
+    my($self, $role, $consumer, @extra) = @_;
+    my $instance;
+
+    if(Mouse::Util::is_a_metaclass($consumer)) {   # Application::ToClass
+        $self->{_to} = 'class';
+    }
+    elsif(Mouse::Util::is_a_metarole($consumer)) { # Application::ToRole
+        $self->{_to} = 'role';
+    }
+    else {                                         # Appplication::ToInstance
+        $self->{_to} = 'instance';
+        $instance  = $consumer;
+
+        $consumer = (Mouse::Util::class_of($instance) || 'Mouse::Meta::Class')
+            ->create_anon_class(
+                superclasses => [ref $instance],
+                cache        => 1,
+            );
+    }
+
+    #$self->check_role_exclusions($role, $consumer, @extra);
+    $self->check_required_methods($role, $consumer, @extra);
+    #$self->check_required_attributes($role, $consumer, @extra);
+
+    $self->apply_attributes($role, $consumer, @extra);
+    $self->apply_methods($role, $consumer, @extra);
+    #$self->apply_override_method_modifiers($role, $consumer, @extra);
+    #$self->apply_before_method_modifiers($role, $consumer, @extra);
+    #$self->apply_around_method_modifiers($role, $consumer, @extra);
+    #$self->apply_after_method_modifiers($role, $consumer, @extra);
+    $self->apply_modifiers($role, $consumer, @extra);
+
+    $self->_append_roles($role, $consumer);
+
+    if(defined $instance){ # Application::ToInstance
+        # rebless instance
+        bless $instance, $consumer->name;
+        $consumer->_initialize_object($instance, $instance, 1);
+    }
+
+    return;
+}
+
+sub check_required_methods {
+    my($self, $role, $consumer) = @_;
+
+    if($self->{_to} eq 'role'){
+        $consumer->add_required_methods($role->get_required_method_list);
+    }
+    else{ # to class or instance
+        my $consumer_class_name = $consumer->name;
+
+        my @missing;
+        foreach my $method_name(@{$role->{required_methods}}){
+            next if exists $self->{aliased_methods}{$method_name};
+            next if exists $role->{methods}{$method_name};
+            next if $consumer_class_name->can($method_name);
+
+            push @missing, $method_name;
+        }
+        if(@missing){
+            $role->throw_error(sprintf "'%s' requires the method%s %s to be implemented by '%s'",
+                $role->name,
+                (@missing == 1 ? '' : 's'), # method or methods
+                Mouse::Util::quoted_english_list(@missing),
+                $consumer_class_name);
+        }
+    }
+
+    return;
+}
+
+sub apply_methods {
+    my($self, $role, $consumer) = @_;
+
+    my $alias    = $self->{-alias};
+    my $excludes = $self->{-excludes};
+
+    foreach my $method_name($role->get_method_list){
+        next if $method_name eq 'meta';
+
+        my $code = $role->get_method_body($method_name);
+
+        if(!exists $excludes->{$method_name}){
+            if(!$consumer->has_method($method_name)){
+                # The third argument $role is used in Role::Composite
+                $consumer->add_method($method_name => $code, $role);
+            }
+        }
+
+        if(exists $alias->{$method_name}){
+            my $dstname = $alias->{$method_name};
+
+            my $dstcode = $consumer->get_method_body($dstname);
+
+            if(defined($dstcode) && $dstcode != $code){
+                $role->throw_error("Cannot create a method alias if a local method of the same name exists");
+            }
+            else{
+                $consumer->add_method($dstname => $code, $role);
+            }
+        }
+    }
+
+    return;
+}
+
+sub apply_attributes {
+    my($self, $role, $consumer) = @_;
+
+    for my $attr_name ($role->get_attribute_list) {
+        next if $consumer->has_attribute($attr_name);
+
+        $consumer->add_attribute($attr_name
+            => $role->get_attribute($attr_name));
+    }
+    return;
+}
+
+sub apply_modifiers {
+    my($self, $role, $consumer) = @_;
+
+    if(my $modifiers = $role->{override_method_modifiers}){
+        foreach my $method_name (keys %{$modifiers}){
+            $consumer->add_override_method_modifier(
+                $method_name => $modifiers->{$method_name});
+        }
+    }
+
+    for my $modifier_type (qw/before around after/) {
+        my $table = $role->{"${modifier_type}_method_modifiers"}
+            or next;
+
+        my $add_modifier = "add_${modifier_type}_method_modifier";
+
+        while(my($method_name, $modifiers) = each %{$table}){
+            foreach my $code(@{ $modifiers }) {
+                # skip if the modifier is already applied
+                next if $consumer->{"_applied_$modifier_type"}{$method_name, $code}++;
+                $consumer->$add_modifier($method_name => $code);
+            }
+        }
+    }
+    return;
+}
+
+sub _append_roles {
+    my($self, $role, $metaclass_or_role) = @_;
+
+    my $roles = $metaclass_or_role->{roles};
+    foreach my $r($role, @{$role->get_roles}){
+        if(!$metaclass_or_role->does_role($r)){
+            push @{$roles}, $r;
+        }
+    }
+    return;
+}
+1;
+__END__
+
+=head1 NAME
+
+Mouse::Meta::Role::Application - The Mouse role application class
+
+=head1 SEE ALSO
+
+L<Moose::Role::Application>
+
+L<Moose::Role::Application::ToClass>
+
+L<Moose::Role::Application::ToRole>
+
+L<Moose::Role::Application::ToInstance>
+
diff --git a/lib/Mouse/Meta/Role/Composite.pm b/lib/Mouse/Meta/Role/Composite.pm
index 7c29969..d7e004a 100644
--- a/lib/Mouse/Meta/Role/Composite.pm
+++ b/lib/Mouse/Meta/Role/Composite.pm
@@ -1,9 +1,10 @@
 package Mouse::Meta::Role::Composite;
 use Mouse::Util; # enables strict and warnings
 use Mouse::Meta::Role;
+use Mouse::Meta::Role::Application;
 our @ISA = qw(Mouse::Meta::Role);
 
-sub get_method_list{
+sub get_method_list {
     my($self) = @_;
     return keys %{ $self->{methods} };
 }
@@ -38,20 +39,20 @@ sub get_method_body {
 
 sub has_method {
     # my($self, $method_name) = @_;
-    return 0; # to fool _apply_methods() in combine()
+    return 0; # to fool apply_methods() in combine()
 }
 
-sub has_attribute{
+sub has_attribute {
     # my($self, $method_name) = @_;
-    return 0; # to fool _appply_attributes() in combine()
+    return 0; # to fool appply_attributes() in combine()
 }
 
-sub has_override_method_modifier{
+sub has_override_method_modifier {
     # my($self, $method_name) = @_;
-    return 0; # to fool _apply_modifiers() in combine()
+    return 0; # to fool apply_modifiers() in combine()
 }
 
-sub add_attribute{
+sub add_attribute {
     my $self      = shift;
     my $attr_name = shift;
     my $spec      = (@_ == 1 ? $_[0] : {@_});
@@ -65,7 +66,7 @@ sub add_attribute{
     return;
 }
 
-sub add_override_method_modifier{
+sub add_override_method_modifier {
     my($self, $method_name, $code) = @_;
 
     my $existing = $self->{override_method_modifiers}{$method_name};
@@ -78,19 +79,30 @@ sub add_override_method_modifier{
     return;
 }
 
-# components of apply()
+sub apply {
+    my $self     = shift;
+    my $consumer = shift;
 
-sub _apply_methods{
-    my($self, $consumer, $args) = @_;
+    Mouse::Meta::Role::Application::RoleSummation->new(@_)->apply($self, $consumer);
+    return;
+}
+
+package Mouse::Meta::Role::Application::RoleSummation;
+our @ISA = qw(Mouse::Meta::Role::Application);
 
-    if(exists $self->{conflicting_methods}){
+sub apply_methods {
+    my($self, $role, $consumer, @extra) = @_;
+
+    if(exists $role->{conflicting_methods}){
         my $consumer_class_name = $consumer->name;
 
-        my @conflicting = grep{ !$consumer_class_name->can($_) } keys %{ $self->{conflicting_methods} };
+        my @conflicting = grep{ !$consumer_class_name->can($_) } 
+            keys %{ $role->{conflicting_methods} };
 
         if(@conflicting == 1){
             my $method_name = $conflicting[0];
-            my $roles       = Mouse::Util::quoted_english_list(map{ $_->name } @{ $self->{composed_roles_by_method}{$method_name} });
+            my $roles       = Mouse::Util::quoted_english_list( map{ $_->name }
+                @{ $role->{composed_roles_by_method}{$method_name} });
             $self->throw_error(
                sprintf q{Due to a method name conflict in roles %s, the method '%s' must be implemented or excluded by '%s'},
                    $roles, $method_name, $consumer_class_name
@@ -101,7 +113,7 @@ sub _apply_methods{
             my $roles = Mouse::Util::quoted_english_list(
                 grep{ !$seen{$_}++ } # uniq
                 map { $_->name }
-                map { @{$_} } @{ $self->{composed_roles_by_method} }{@conflicting}
+                map { @{$_} } @{ $role->{composed_roles_by_method} }{@conflicting}
             );
 
             $self->throw_error(
@@ -113,9 +125,11 @@ sub _apply_methods{
         }
     }
 
-    $self->SUPER::_apply_methods($consumer, $args);
+    $self->SUPER::apply_methods($role, $consumer, @extra);
     return;
 }
+
+package Mouse::Meta::Role::Composite;
 1;
 __END__
 
diff --git a/lib/Mouse/Meta/TypeConstraint.pm b/lib/Mouse/Meta/TypeConstraint.pm
index df04f78..7817b15 100644
--- a/lib/Mouse/Meta/TypeConstraint.pm
+++ b/lib/Mouse/Meta/TypeConstraint.pm
@@ -234,11 +234,6 @@ sub _unite { # overload infix:<|>
     );
 }
 
-sub throw_error {
-    require Mouse::Meta::Module;
-    goto &Mouse::Meta::Module::throw_error;
-}
-
 1;
 __END__
 
diff --git a/lib/Mouse/PurePerl.pm b/lib/Mouse/PurePerl.pm
index 73374b4..36ef0ce 100644
--- a/lib/Mouse/PurePerl.pm
+++ b/lib/Mouse/PurePerl.pm
@@ -384,9 +384,8 @@ sub _initialize_object{
 
 sub is_immutable {  $_[0]->{is_immutable} }
 
-Mouse::Util::install_subroutines(__PACKAGE__,
-    strict_constructor => $generate_class_accessor->('strict_constructor'),
-);
+sub strict_constructor;
+*strict_constructor = $generate_class_accessor->('strict_constructor');
 
 sub _report_unknown_args {
     my($metaclass, $attrs, $args) = @_;
diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm
index 6d107da..393bccf 100644
--- a/lib/Mouse/Util.pm
+++ b/lib/Mouse/Util.pm
@@ -38,13 +38,13 @@ BEGIN{
 
             not_supported
 
-            does meta dump
+            does meta throw_error dump
         )],
         groups => {
             default => [], # export no functions by default
 
             # The ':meta' group is 'use metaclass' for Mouse
-            meta    => [qw(does meta dump)],
+            meta    => [qw(does meta dump throw_error)],
         },
     );
 
@@ -67,7 +67,7 @@ BEGIN{
             Mouse::Util->import({ into => 'Mouse::Meta::Method::Accessor::XS'    }, ':meta');
             return 1;
         } || 0;
-        #warn $@ if $@;
+        warn $@ if $@ && $ENV{MOUSE_XS};
     }
 
     if(!$xs){
@@ -337,6 +337,22 @@ sub meta :method{
     return Mouse::Meta::Class->initialize(ref($_[0]) || $_[0]);
 }
 
+# general throw_error() method
+# $o->throw_error($msg, depth => $leve, longmess => $croak_or_confess)
+sub throw_error :method {
+    my($self, $message, %args) = @_;
+
+    local $Carp::CarpLevel  = $Carp::CarpLevel + 1 + ($args{depth} || 0);
+    local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though
+
+    if(exists $args{longmess} && !$args{longmess}) {
+        Carp::croak($message);
+    }
+    else{
+        Carp::confess($message);
+    }
+}
+
 # general dump() method
 sub dump :method {
     my($self, $maxdepth) = @_;