From: Stevan Little <stevan.little@iinteractive.com>
Date: Sat, 19 Jan 2008 16:56:36 +0000 (+0000)
Subject: rudementary support for attribute traits
X-Git-Tag: 0_35~12
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d9bb6c63aaf7a085b8bfe6afcd7a35b727ea97c6;p=gitmo%2FMoose.git

rudementary support for attribute traits
---

diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index ebc3528..265f037 100644
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -158,18 +158,7 @@ sub get_method_map {
 
 sub add_attribute {
     my $self = shift;
-    my $name = shift;
-    if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
-        # NOTE:
-        # if it is a HASH ref, we de-ref it.
-        # this will usually mean that it is
-        # coming from a role
-        $self->SUPER::add_attribute($self->_process_attribute($name => %{$_[0]}));
-    }
-    else {
-        # otherwise we just pass the args
-        $self->SUPER::add_attribute($self->_process_attribute($name => @_));
-    }
+    $self->SUPER::add_attribute($self->_process_attribute(@_));
 }
 
 sub add_override_method_modifier {
@@ -279,17 +268,23 @@ sub _fix_metaclass_incompatability {
 }
 
 # NOTE:
-# this was crap anyway, see 
-# Moose::Util::apply_all_roles 
+# this was crap anyway, see
+# Moose::Util::apply_all_roles
 # instead
 sub _apply_all_roles { die "DEPRECATED" }
 
+my %ANON_CLASSES;
+
 sub _process_attribute {
-    my ($self, $name, %options) = @_;
+    my $self    = shift;
+    my $name    = shift;
+    my %options = ((scalar @_ == 1 && ref($_[0]) eq 'HASH') ? %{$_[0]} : @_);
+
     if ($name =~ /^\+(.*)/) {
         return $self->_process_inherited_attribute($1, %options);
     }
     else {
+        my $attr_metaclass_name;
         if ($options{metaclass}) {
             my $metaclass_name = $options{metaclass};
             eval {
@@ -302,11 +297,32 @@ sub _process_attribute {
             if ($@) {
                 Class::MOP::load_class($metaclass_name);
             }
-            return $metaclass_name->new($name, %options);
+            $attr_metaclass_name = $metaclass_name;
         }
         else {
-            return $self->attribute_metaclass->new($name, %options);
+            $attr_metaclass_name = $self->attribute_metaclass;
         }
+
+        if ($options{traits}) {
+
+            my $anon_role_key = join "|" => @{$options{traits}};
+
+            my $class;
+            if (exists $ANON_CLASSES{$anon_role_key} && defined $ANON_CLASSES{$anon_role_key}) {
+                $class = $ANON_CLASSES{$anon_role_key};
+            }
+            else {
+                $class = Moose::Meta::Class->create_anon_class(
+                    superclasses => [ $attr_metaclass_name ]
+                );
+                $ANON_CLASSES{$anon_role_key} = $class;
+                Moose::Util::apply_all_roles($class, @{$options{traits}});
+            }
+            
+            $attr_metaclass_name = $class->name;
+        }
+
+        return $attr_metaclass_name->new($name, %options);
     }
 }
 
diff --git a/lib/Moose/Util.pm b/lib/Moose/Util.pm
index f4bc473..cad5539 100644
--- a/lib/Moose/Util.pm
+++ b/lib/Moose/Util.pm
@@ -74,15 +74,7 @@ sub apply_all_roles {
     #use Data::Dumper;
     #warn Dumper $roles;
     
-    my $meta;
-    if (blessed $applicant                     && 
-        ($applicant->isa('Class::MOP::Class')  || 
-         $applicant->isa('Moose::Meta::Role')) ){
-        $meta = $applicant;
-    }
-    else {
-        $meta = find_meta($applicant);
-    }
+    my $meta = (blessed $applicant ? $applicant : find_meta($applicant));
     
     Class::MOP::load_class($_->[0]) for @$roles;
     
@@ -101,6 +93,7 @@ sub apply_all_roles {
     }    
 }
 
+
 1;
 
 __END__
diff --git a/t/020_attributes/015_attribute_traits.t b/t/020_attributes/015_attribute_traits.t
new file mode 100644
index 0000000..4683e3d
--- /dev/null
+++ b/t/020_attributes/015_attribute_traits.t
@@ -0,0 +1,46 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+use Test::Exception;
+
+BEGIN {
+    use_ok('Moose');
+}
+
+{
+    package My::Attribute::Trait;
+    use Moose::Role;
+    
+    has 'alias_to' => (is => 'ro', isa => 'Str');
+    
+    after 'install_accessors' => sub {
+        my $self = shift;
+        $self->associated_class->add_method(
+            $self->alias_to, 
+            $self->get_read_method_ref
+        );
+    };
+}
+
+{
+    package My::Class;
+    use Moose;
+    
+    has 'bar' => (
+        traits   => [qw/My::Attribute::Trait/],
+        is       => 'ro',
+        isa      => 'Int',
+        alias_to => 'baz',
+    );
+}
+
+my $c = My::Class->new(bar => 100);
+isa_ok($c, 'My::Class');
+
+is($c->bar, 100, '... got the right value for bar');
+
+can_ok($c, 'baz');
+is($c->baz, 100, '... got the right value for baz');
diff --git a/t/300_immutable/002_apply_roles_to_immutable.t b/t/300_immutable/002_apply_roles_to_immutable.t
new file mode 100644
index 0000000..e4e0c3e
--- /dev/null
+++ b/t/300_immutable/002_apply_roles_to_immutable.t
@@ -0,0 +1,43 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+use Test::Exception;
+
+BEGIN {
+    use_ok('Moose');
+}
+
+{
+    package My::Role;
+    use Moose::Role;
+    
+    around 'baz' => sub { 
+        my $next = shift;
+        'My::Role::baz(' . $next->(@_) . ')';
+    };
+}
+
+{
+    package Foo;
+    use Moose;
+    
+    sub baz { 'Foo::baz' }
+    
+	__PACKAGE__->meta->make_immutable(debug => 0);
+}
+
+my $foo = Foo->new;
+isa_ok($foo, 'Foo');
+
+is($foo->baz, 'Foo::baz', '... got the right value');
+
+lives_ok {
+    My::Role->meta->apply($foo)
+} '... successfully applied the role to immutable instance';
+
+is($foo->baz, 'My::Role::baz(Foo::baz)', '... got the right value');
+
+