X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=lib%2FMouse%2FUtil%2FMetaRole.pm;h=8334bd57f40f772aba4f7242e3125afa71a1f188;hp=fe68cbeb41ddf173305e284e61db44f313716d53;hb=241dd25c9f7c42a3b5dfd105d36869ed15d3d6d5;hpb=f87debb99f7c14e24071098c395fbe7331894d49

diff --git a/lib/Mouse/Util/MetaRole.pm b/lib/Mouse/Util/MetaRole.pm
index fe68cbe..8334bd5 100644
--- a/lib/Mouse/Util/MetaRole.pm
+++ b/lib/Mouse/Util/MetaRole.pm
@@ -1,37 +1,106 @@
 package Mouse::Util::MetaRole;
 use Mouse::Util; # enables strict and warnings
-
-our @Classes = qw(constructor_class destructor_class);
+use Scalar::Util ();
 
 sub apply_metaclass_roles {
-    my %options = @_;
+    my %args = @_;
+    _fixup_old_style_args(\%args);
+
+    return apply_metaroles(%args);
+}
+
+sub apply_metaroles {
+    my %args = @_;
+
+    my $for = Scalar::Util::blessed($args{for})
+        ?                                     $args{for}
+        : Mouse::Util::get_metaclass_by_name( $args{for} );
+
+    if ( Mouse::Util::is_a_metarole($for) ) {
+        return _make_new_metaclass( $for, $args{role_metaroles}, 'role' );
+    }
+    else {
+        return _make_new_metaclass( $for, $args{class_metaroles}, 'class' );
+    }
+}
+
+sub _make_new_metaclass {
+    my($for, $roles, $primary) = @_;
+
+    return $for unless keys %{$roles};
+
+    my $new_metaclass = exists($roles->{$primary})
+        ? _make_new_class( ref $for, $roles->{$primary} ) # new class with traits
+        :                  ref $for;
+
+    my %classes;
 
-    my $for = Scalar::Util::blessed($options{for_class})
-        ? $options{for_class}
-        : Mouse::Util::class_of($options{for_class});
+    for my $key ( grep { $_ ne $primary } keys %{$roles} ) {
+        my $metaclass;
+        my $attr = $for->can($metaclass = ($key . '_metaclass'))
+                || $for->can($metaclass = ($key . '_class'))
+                || $for->throw_error("Unknown metaclass '$key'");
 
-    my %old_classes = map { $for->can($_) ? ($_ => $for->$_) : () }
-                      @Classes;
+        $classes{ $metaclass }
+            = _make_new_class( $for->$attr(), $roles->{$key} );
+    }
+
+    return $new_metaclass->reinitialize( $for, %classes );
+}
+
+
+sub _fixup_old_style_args {
+    my $args = shift;
+
+    return if $args->{class_metaroles} || $args->{roles_metaroles};
+
+    $args->{for} = delete $args->{for_class}
+        if exists $args->{for_class};
+
+    my @old_keys = qw(
+        attribute_metaclass_roles
+        method_metaclass_roles
+        wrapped_method_metaclass_roles
+        instance_metaclass_roles
+        constructor_class_roles
+        destructor_class_roles
+        error_class_roles
+
+        application_to_class_class_roles
+        application_to_role_class_roles
+        application_to_instance_class_roles
+        application_role_summation_class_roles
+    );
+
+    my $for = Scalar::Util::blessed($args->{for})
+        ?                                     $args->{for}
+        : Mouse::Util::get_metaclass_by_name( $args->{for} );
+
+    my $top_key;
+    if( Mouse::Util::is_a_metaclass($for) ){
+        $top_key = 'class_metaroles';
+
+        $args->{class_metaroles}{class} = delete $args->{metaclass_roles}
+            if exists $args->{metaclass_roles};
+    }
+    else {
+        $top_key = 'role_metaroles';
 
-    my $meta = _make_new_metaclass( $for, \%options );
+        $args->{role_metaroles}{role} = delete $args->{metaclass_roles}
+            if exists $args->{metaclass_roles};
+    }
 
-    for my $c ( grep { $meta->can($_) } @Classes ) {
-        if ( $options{ $c . '_roles' } ) {
-            my $class = _make_new_class(
-                $meta->$c(),
-                $options{ $c . '_roles' }
-            );
+    for my $old_key (@old_keys) {
+        my ($new_key) = $old_key =~ /^(.+)_(?:class|metaclass)_roles$/;
 
-            $meta->$c($class);
-        }
-        elsif($meta->$c ne $old_classes{$c}){
-            $meta->$c( $old_classes{$c} );
-        }
+        $args->{$top_key}{$new_key} = delete $args->{$old_key}
+            if exists $args->{$old_key};
     }
 
-    return $meta;
+    return;
 }
 
+
 sub apply_base_class_roles {
     my %options = @_;
 
@@ -50,40 +119,17 @@ sub apply_base_class_roles {
     return;
 }
 
-
-my @Metaclasses = qw(
-    metaclass
-    attribute_metaclass
-    method_metaclass
-);
-
-sub _make_new_metaclass {
-    my($for, $options) = @_;
-
-    return $for
-        if !grep { exists $options->{ $_ . '_roles' } } @Metaclasses;
-
-    my $new_metaclass
-        = _make_new_class( ref $for, $options->{metaclass_roles} );
-
-    # This could get called for a Mouse::Meta::Role as well as a Mouse::Meta::Class
-    my %classes = map {
-        $_ => _make_new_class( $for->$_(), $options->{ $_ . '_roles' } )
-    }  grep { $for->can($_) } @Metaclasses;
-
-    return $new_metaclass->reinitialize( $for, %classes );
-}
-
-
 sub _make_new_class {
     my($existing_class, $roles, $superclasses) = @_;
 
-    return $existing_class if !$roles;
+    if(!$superclasses){
+        return $existing_class if !$roles;
 
-    my $meta = Mouse::Meta::Class->initialize($existing_class);
+        my $meta = Mouse::Meta::Class->initialize($existing_class);
 
-    return $existing_class
-        if !grep { !ref($_) && !$meta->does_role($_) } @{$roles};
+        return $existing_class
+            if !grep { !ref($_) && !$meta->does_role($_) } @{$roles};
+    }
 
     return Mouse::Meta::Class->create_anon_class(
         superclasses => $superclasses ? $superclasses : [$existing_class],
@@ -93,7 +139,6 @@ sub _make_new_class {
 }
 
 1;
-
 __END__
 
 =head1 NAME
@@ -116,22 +161,24 @@ Mouse::Util::MetaRole - Apply roles to any metaclass, as well as the object base
 
   sub init_meta {
       shift;
-      my %options = @_;
+      my %args = @_;
 
-      Mouse->init_meta(%options);
+      Mouse->init_meta(%args);
 
-      Mouse::Util::MetaRole::apply_metaclass_roles(
-          for_class               => $options{for_class},
-          metaclass_roles         => ['MyApp::Role::Meta::Class'],
-          constructor_class_roles => ['MyApp::Role::Meta::Method::Constructor'],
+      Mouse::Util::MetaRole::apply_metaroles(
+          for             => $args{for_class},
+          class_metaroles => {
+              class       => ['MyApp::Role::Meta::Class'],
+              constructor => ['MyApp::Role::Meta::Method::Constructor'],
+          },
       );
 
       Mouse::Util::MetaRole::apply_base_class_roles(
-          for_class => $options{for_class},
-          roles     => ['MyApp::Role::Object'],
+          for   => $args{for_class},
+          roles => ['MyApp::Role::Object'],
       );
 
-      return $options{for_class}->meta();
+      return $args{for_class}->meta();
   }
 
 =head1 DESCRIPTION
@@ -162,38 +209,64 @@ method for you, and make sure it is called when imported.
 
 This module provides two functions.
 
-=head2 apply_metaclass_roles( ... )
+=head2 apply_metaroles( ... )
 
 This function will apply roles to one or more metaclasses for the
 specified class. It accepts the following parameters:
 
 =over 4
 
-=item * for_class => $name
+=item * for => $name
+
+This specifies the class or for which to alter the meta classes. This can be a
+package name, or an appropriate meta-object (a L<Mouse::Meta::Class> or
+L<Mouse::Meta::Role>).
+
+=item * class_metaroles => \%roles
+
+This is a hash reference specifying which metaroles will be applied to the
+class metaclass and its contained metaclasses and helper classes.
 
-This specifies the class for which to alter the meta classes.
+Each key should in turn point to an array reference of role names.
 
-=item * metaclass_roles => \@roles
+It accepts the following keys:
 
-=item * attribute_metaclass_roles => \@roles
+=over 8
 
-=item * method_metaclass_roles => \@roles
+=item class
 
-=item * constructor_class_roles => \@roles
+=item attribute
 
-=item * destructor_class_roles => \@roles
+=item method
+
+=item constructor
+
+=item destructor
+
+=back
 
-These parameter all specify one or more roles to be applied to the
-specified metaclass. You can pass any or all of these parameters at
-once.
+=item * role_metaroles => \%roles
+
+This is a hash reference specifying which metaroles will be applied to the
+role metaclass and its contained metaclasses and helper classes.
+
+It accepts the following keys:
+
+=over 8
+
+=item role
+
+=item method
+
+=back
 
 =back
 
-=head2 apply_base_class_roles( for_class => $class, roles => \@roles )
+=head2 apply_base_class_roles( for => $class, roles => \@roles )
 
 This function will apply the specified roles to the object's base class.
 
-=head1 SEE ASLSO
+=head1 SEE ALSO
 
 L<Moose::Util::MetaRole>