From: Dave Rolsky <autarch@urth.org>
Date: Thu, 17 Dec 2009 17:29:55 +0000 (-0600)
Subject: Real attribute objects in roles is now working, with a few hacks and changes to the... 
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=721b5f293969f5cf1b6863fb4cc1361f4bfbb9d8;p=gitmo%2FMoose.git

Real attribute objects in roles is now working, with a few hacks and changes to the core code.

This will need serious review before merging.
---

diff --git a/lib/Moose/Meta/Attribute/Native/Trait.pm b/lib/Moose/Meta/Attribute/Native/Trait.pm
index 311ee28..76db962 100644
--- a/lib/Moose/Meta/Attribute/Native/Trait.pm
+++ b/lib/Moose/Meta/Attribute/Native/Trait.pm
@@ -34,9 +34,6 @@ has 'method_constructors' => (
     },
 );
 
-has '+default'         => ( required => 1 );
-has '+type_constraint' => ( required => 1 );
-
 # methods called prior to instantiation
 
 before '_process_options' => sub {
diff --git a/lib/Moose/Meta/Attribute/Trait/InRole.pm b/lib/Moose/Meta/Attribute/Trait/InRole.pm
new file mode 100644
index 0000000..f464098
--- /dev/null
+++ b/lib/Moose/Meta/Attribute/Trait/InRole.pm
@@ -0,0 +1,61 @@
+package Moose::Meta::Attribute::Trait::InRole;
+
+use Moose::Role;
+
+use Carp 'confess';
+use Scalar::Util 'blessed', 'weaken';
+
+our $VERSION   = '0.93';
+our $AUTHORITY = 'cpan:STEVAN';
+
+around attach_to_class => sub {
+    shift;
+    my ( $self, $class ) = @_;
+
+    ( blessed($class) && $class->isa('Moose::Meta::Role') )
+        || confess
+        "You must pass a Moose::Meta::Role instance (or a subclass)";
+
+    weaken( $self->{'associated_class'} = $class );
+};
+
+# XXX - This is a no-op, since trying to add accessors to a role just blows
+# up. Ideally, we _would_ add accessors, or somehow make the role aware that
+# they exist for the purposes of method conflict checking, etc.
+around install_accessors => sub { };
+
+around _check_associated_methods => sub { };
+
+around clone => sub {
+    my $orig = shift;
+    my $self = shift;
+
+    my $meta = $self->meta;
+
+    my @supers = $meta->superclasses();
+    my @traits_to_keep = grep { $_ ne __PACKAGE__ }
+        map  { $_->name }
+        grep { !$_->isa('Moose::Meta::Role::Composite') }
+        $meta->calculate_all_roles;
+
+    my $new_class;
+
+    if ( @traits_to_keep || @supers > 1 ) {
+        my $anon_class = Moose::Meta::Class->create_anon_class(
+            superclasses => \@supers,
+            roles        => \@traits_to_keep,
+            cache        => 1,
+        );
+
+        $new_class = $anon_class->name;
+    }
+    else {
+        $new_class = $supers[0];
+    }
+
+    return $self->$orig( @_, metaclass => $new_class );
+};
+
+no Moose::Role;
+
+1;
diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm
index 9bc4310..9ca9983 100644
--- a/lib/Moose/Meta/Role.pm
+++ b/lib/Moose/Meta/Role.pm
@@ -17,8 +17,9 @@ use Moose::Meta::Class;
 use Moose::Meta::Role::Method;
 use Moose::Meta::Role::Method::Required;
 use Moose::Meta::Role::Method::Conflicting;
+use Moose::Util qw( ensure_all_roles );
 
-use base 'Class::MOP::Module';
+use base 'Class::MOP::Module', 'Class::MOP::HasAttributes';
 
 ## ------------------------------------------------------------------
 ## NOTE:
@@ -70,16 +71,6 @@ foreach my $action (
             existence  => 'requires_method',
         }
     },
-    {
-        name        => '_attribute_map',
-        attr_reader => '_attribute_map',
-        methods     => {
-            get       => 'get_attribute',
-            get_keys  => 'get_attribute_list',
-            existence => 'has_attribute',
-            remove    => 'remove_attribute',
-        }
-    }
 ) {
 
     my $attr_reader = $action->{attr_reader};
@@ -165,23 +156,64 @@ $META->add_attribute(
     predicate => 'has_composition_class_roles',
 );
 
-## some things don't always fit, so they go here ...
+# More or less copied from Moose::Meta::Class
+sub initialize {
+    my $class = shift;
+    my $pkg   = shift;
+    return Class::MOP::get_metaclass_by_name($pkg)
+        || $class->SUPER::initialize(
+        $pkg,
+        'attribute_metaclass' => 'Moose::Meta::Attribute',
+        @_
+        );
+}
 
+my $Role_Loaded;
+# XXX - copied from Moose::Meta::Class
 sub add_attribute {
     my $self = shift;
-    my $name = shift;
-    unless ( defined $name ) {
-        require Moose;
-        Moose->throw_error("You must provide a name for the attribute");
+
+    # Since this _is_ a role, it needs to be loaded after Moose::Meta::Role is
+    # done setting itself up.
+    unless ($Role_Loaded) {
+        require Moose::Meta::Attribute::Trait::InRole;
+        $Role_Loaded = 1;
     }
-    my $attr_desc;
-    if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
-        $attr_desc = $_[0];
+
+    my $attr = (
+        blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
+        ? $self->_ensure_attribute_trait($_[0] )
+        : $self->_process_attribute(@_)
+    );
+
+    $self->SUPER::add_attribute($attr);
+
+    return $attr;
+}
+
+sub _ensure_attribute_trait {
+    my $self = shift;
+    my $attr = shift;
+
+    ensure_all_roles( $attr, 'Moose::Meta::Attribute::Trait::InRole' );
+
+    return $attr;
+}
+
+sub _process_attribute {
+    my ( $self, $name, @args ) = @_;
+
+    my %args = scalar @args == 1
+        && ref( $args[0] ) eq 'HASH' ? %{ $args[0] } : @args;
+
+    if ( $args{traits} ) {
+        push @{ $args{traits} }, 'Moose::Meta::Attribute::Trait::InRole';
     }
     else {
-        $attr_desc = { @_ };
+        $args{traits} = ['Moose::Meta::Attribute::Trait::InRole'];
     }
-    $self->_attribute_map->{$name} = $attr_desc;
+
+    $self->attribute_metaclass->interpolate_class_and_new( $name, %args );
 }
 
 sub add_required_methods {
@@ -564,20 +596,6 @@ sub create {
 #     }
 # );
 #
-# has 'attribute_map' => (
-#     metaclass => 'Hash',
-#     reader    => '_attribute_map',
-#     isa       => 'HashRef[Str]',
-#     provides => {
-#         # 'set'  => 'add_attribute' # has some special crap in it
-#         'get'    => 'get_attribute',
-#         'keys'   => 'get_attribute_list',
-#         'exists' => 'has_attribute',
-#         # Not exactly delete, cause it sets multiple
-#         'delete' => 'remove_attribute',
-#     }
-# );
-#
 # has 'required_methods' => (
 #     metaclass => 'Hash',
 #     reader    => 'get_required_methods_map',
diff --git a/lib/Moose/Meta/Role/Application/RoleSummation.pm b/lib/Moose/Meta/Role/Application/RoleSummation.pm
index 8532276..a0d2ce7 100644
--- a/lib/Moose/Meta/Role/Application/RoleSummation.pm
+++ b/lib/Moose/Meta/Role/Application/RoleSummation.pm
@@ -116,30 +116,37 @@ sub check_required_attributes {
 sub apply_attributes {
     my ($self, $c) = @_;
 
-    my @all_attributes = map {
-        my $role = $_;
-        map {
-            +{
-                name => $_,
-                attr => $role->get_attribute($_),
-            }
-        } $role->get_attribute_list
-    } @{$c->get_roles};
+    my @all_attributes;
+
+    for my $role ( @{ $c->get_roles } ) {
+        push @all_attributes,
+            map { $role->get_attribute($_) } $role->get_attribute_list;
+    }
 
     my %seen;
     foreach my $attr (@all_attributes) {
-        if (exists $seen{$attr->{name}}) {
-            if ( $seen{$attr->{name}} != $attr->{attr} ) {
+        my $name = $attr->name;
+
+        if ( exists $seen{$name} ) {
+            if ( $seen{$name} != $attr ) {
+                my $role1 = $seen{$name}->associated_class->name;
+                my $role2 = $attr->associated_class->name;
+
                 require Moose;
-                Moose->throw_error("We have encountered an attribute conflict with '" . $attr->{name} . "' "
-                                   . "during composition. This is fatal error and cannot be disambiguated.")
+                Moose->throw_error(
+                    "We have encountered an attribute conflict with '$name' "
+                        . "during role composition. "
+                        . " This attribute is defined in both $role1 and $role2."
+                        . " This is fatal error and cannot be disambiguated."
+                );
             }
         }
-        $seen{$attr->{name}} = $attr->{attr};
+
+        $seen{$name} = $attr;
     }
 
     foreach my $attr (@all_attributes) {
-        $c->add_attribute($attr->{name}, $attr->{attr});
+        $c->add_attribute($attr);
     }
 }
 
diff --git a/lib/Moose/Meta/Role/Application/ToClass.pm b/lib/Moose/Meta/Role/Application/ToClass.pm
index f9f5239..e3e6d80 100644
--- a/lib/Moose/Meta/Role/Application/ToClass.pm
+++ b/lib/Moose/Meta/Role/Application/ToClass.pm
@@ -36,6 +36,9 @@ sub apply {
 
 sub check_role_exclusions {
     my ($self, $role, $class) = @_;
+    if (ref $class eq 'Class::MOP::Class' ){
+        Carp::cluck('wtf');
+    }
     if ($class->excludes_role($role->name)) {
         $class->throw_error("Conflict detected: " . $class->name . " excludes role '" . $role->name . "'");
     }
@@ -138,8 +141,7 @@ sub apply_attributes {
         }
         else {
             $class->add_attribute(
-                $attribute_name,
-                $role->get_attribute($attribute_name)
+                $role->get_attribute($attribute_name)->clone
             );
         }
     }
diff --git a/lib/Moose/Meta/Role/Application/ToInstance.pm b/lib/Moose/Meta/Role/Application/ToInstance.pm
index 184ca89..a0c85cf 100644
--- a/lib/Moose/Meta/Role/Application/ToInstance.pm
+++ b/lib/Moose/Meta/Role/Application/ToInstance.pm
@@ -30,6 +30,14 @@ sub apply {
     }
     else {
         my $obj_meta = Class::MOP::class_of($object) || 'Moose::Meta::Class';
+
+        # This is a special case to handle the case where the object's
+        # metaclass is a Class::MOP::Class, but _not_ a Moose::Meta::Class
+        # (for example, when applying a role to a Moose::Meta::Attribute
+        # object).
+        $obj_meta = 'Moose::Meta::Class'
+            unless $obj_meta->isa('Moose::Meta::Class');
+
         $class = $obj_meta->create_anon_class(
             superclasses => [ blessed($object) ]
         );
diff --git a/lib/Moose/Meta/Role/Application/ToRole.pm b/lib/Moose/Meta/Role/Application/ToRole.pm
index 1a752fa..6c4085b 100644
--- a/lib/Moose/Meta/Role/Application/ToRole.pm
+++ b/lib/Moose/Meta/Role/Application/ToRole.pm
@@ -63,7 +63,6 @@ sub apply_attributes {
         }
         else {
             $role2->add_attribute(
-                $attribute_name,
                 $role1->get_attribute($attribute_name)
             );
         }
diff --git a/t/020_attributes/005_attribute_does.t b/t/020_attributes/005_attribute_does.t
index 6d00c67..945717b 100644
--- a/t/020_attributes/005_attribute_does.t
+++ b/t/020_attributes/005_attribute_does.t
@@ -21,6 +21,11 @@ use Test::Exception;
         does => role_type('Bar::Role')
     );
 
+    package Foo::Class;
+    use Moose;
+
+    with 'Foo::Role';
+
     package Bar::Role;
     use Moose::Role;
 
@@ -29,16 +34,10 @@ use Test::Exception;
     # since the isa() check will imply the does() check
     has 'foo' => (is => 'rw', isa => 'Foo::Class', does => 'Foo::Role');
 
-    package Foo::Class;
-    use Moose;
-
-    with 'Foo::Role';
-
     package Bar::Class;
     use Moose;
 
     with 'Bar::Role';
-
 }
 
 my $foo = Foo::Class->new;
diff --git a/t/030_roles/001_meta_role.t b/t/030_roles/001_meta_role.t
index 309f4b1..bc86e1a 100644
--- a/t/030_roles/001_meta_role.t
+++ b/t/030_roles/001_meta_role.t
@@ -55,10 +55,14 @@ is_deeply(
 
 ok($foo_role->has_attribute('bar'), '... FooRole does have the bar attribute');
 
-is_deeply(
-    $foo_role->get_attribute('bar'),
-    { is => 'rw', isa => 'Foo' },
-    '... got the correct description of the bar attribute');
+my $bar = $foo_role->get_attribute('bar');
+is( $bar->get_read_method, 'bar', 'bar has a reader named bar' );
+is( $bar->get_write_method, 'bar', 'bar has a writer named bar' );
+is(
+    $bar->type_constraint,
+    Moose::Util::TypeConstraints::class_type('Foo'),
+    'bar has a Foo class type'
+);
 
 lives_ok {
     $foo_role->add_attribute('baz' => (is => 'ro'));
@@ -71,10 +75,9 @@ is_deeply(
 
 ok($foo_role->has_attribute('baz'), '... FooRole does have the baz attribute');
 
-is_deeply(
-    $foo_role->get_attribute('baz'),
-    { is => 'ro' },
-    '... got the correct description of the baz attribute');
+my $baz = $foo_role->get_attribute('baz');
+is( $baz->get_read_method, 'baz', 'baz has a reader named baz' );
+is( $baz->get_write_method, undef, 'baz does not have a writer' );
 
 lives_ok {
     $foo_role->remove_attribute('bar');
diff --git a/t/050_metaclasses/030_metarole_combination.t b/t/050_metaclasses/030_metarole_combination.t
index 2b1e928..57ccad6 100644
--- a/t/050_metaclasses/030_metarole_combination.t
+++ b/t/050_metaclasses/030_metarole_combination.t
@@ -97,8 +97,9 @@ our @applications;
     package Role::WithCustomApplication;
     use Moose::Role;
 
-    has '+composition_class_roles' => (
-        default => ['Role::Composite'],
+    has 'composition_class_roles' => (
+        is      => 'bare',
+        default => sub { ['Role::Composite'] },
     );
 }
 
diff --git a/t/600_todo_tests/002_various_role_features.t b/t/600_todo_tests/002_various_role_features.t
index deab7fe..eee944c 100644
--- a/t/600_todo_tests/002_various_role_features.t
+++ b/t/600_todo_tests/002_various_role_features.t
@@ -192,11 +192,7 @@ my $gorch = Gorch->meta;
 isa_ok( $gorch, "Moose::Meta::Role" );
 
 ok( $gorch->has_attribute("attr"), "has attribute 'attr'" );
-
-{
-    local $TODO = "role attribute isn't a meta attribute yet";
-    isa_ok( $gorch->get_attribute("attr"), "Moose::Meta::Attribute" );
-}
+isa_ok( $gorch->get_attribute("attr"), "Moose::Meta::Attribute" );
 
 req_or_has($gorch, "gorch_method");
 ok( $gorch->has_method("gorch_method"), "has_method gorch_method" );
@@ -226,11 +222,7 @@ my $robot = Dancer::Robot->meta;
 isa_ok( $robot, "Moose::Meta::Role" );
 
 ok( $robot->has_attribute("twist"), "has attr 'twist'" );
-
-{
-    local $TODO = "role attribute isn't a meta attribute yet";
-    isa_ok( $robot->get_attribute("twist"), "Moose::Meta::Attribute" );
-}
+isa_ok( $robot->get_attribute("twist"), "Moose::Meta::Attribute" );
 
 {
     req_or_has($robot, "twist");