Overriding additional attribute options with has +$foo

[email protected] (Tomas Doran) Wed, 16 Apr 2008 20:21:39 +0100

Newsgroups	perl.moose
Message-ID	<[email protected]>

Hiya

First of all, just to say I'm pretty new to Moose (started hacking on  
Saturday), so excuse me if I'm either missing totally obvious things,  
or messing up the lingo..

One of the things that I've found is that I want to be able to  
override additional options to attributes when composing roles  
(making Class::Workflow and MooseX::Storage play together nicely),  
and I found that you can't change either the 'metaclass' or the  
'traits' with has +$foo..

After a quick discussion on #moose the other day Stevan agreed that  
both of these were sane and nothingmuch volunteered to write the  
patch if I submitted some tests.

Please find a diff attached with tests, docs and the metaclass option  
fixed - I haven't touched the attribute traits yet (other than the  
tests), as I'm yet to wrap my head around them properly...

Cheers
Tom

moose-+has-extra-options.diff (application/octet-stream, 4.4 KB)

Only in Moose-0.40: blib
diff -ur Moose-0.40.orig/lib/Moose/Meta/Attribute.pm Moose-0.40/lib/Moose/Meta/Attribute.pm
--- Moose-0.40.orig/lib/Moose/Meta/Attribute.pm	2008-04-14 19:27:05.000000000 +0100
+++ Moose-0.40/lib/Moose/Meta/Attribute.pm	2008-04-16 20:14:19.000000000 +0100
@@ -65,7 +65,7 @@
     my ($self, %options) = @_;
     # you can change default, required, coerce, documentation and lazy
     my %actual_options;
-    foreach my $legal_option (qw(default coerce required documentation lazy)) {
+    foreach my $legal_option (qw(default coerce required documentation lazy metaclass)) {
         if (exists $options{$legal_option}) {
             $actual_options{$legal_option} = $options{$legal_option};
             delete $options{$legal_option};
@@ -86,8 +86,8 @@
             if $self->has_builder;
         $actual_options{builder} = $options{builder};
         delete $options{builder};
-    }    
-
+    }
+    
     # isa can be changed, but only if the
     # new type is a subtype
     if ($options{isa}) {
diff -ur Moose-0.40.orig/lib/Moose.pm Moose-0.40/lib/Moose.pm
--- Moose-0.40.orig/lib/Moose.pm	2008-04-14 19:27:05.000000000 +0100
+++ Moose-0.40/lib/Moose.pm	2008-04-14 22:26:44.000000000 +0100
@@ -691,6 +691,17 @@
 You are allowed to B<add> a new C<builder> definition, but you are B<not>
 allowed to I<change> one.
 
+=item I<metaclass>
+
+You are allowed to B<add> a new C<metaclass> definition, but you are
+B<not> allowed to I<change one.
+
+=item I<traits>
+
+You are allowed to B<add> additional traits to the C<traits> definition.
+These traits will be composed into the attribute, but pre-existing traits
+B<are not> overridden, or removed.
+
 =back
 
 =item B<before $name|@names =E<gt> sub { ... }>
diff -ur Moose-0.40.orig/t/020_attributes/009_attribute_inherited_slot_specs.t Moose-0.40/t/020_attributes/009_attribute_inherited_slot_specs.t
--- Moose-0.40.orig/t/020_attributes/009_attribute_inherited_slot_specs.t	2008-04-14 19:27:05.000000000 +0100
+++ Moose-0.40/t/020_attributes/009_attribute_inherited_slot_specs.t	2008-04-16 20:12:17.000000000 +0100
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 84;
+use Test::More tests => 86;
 use Test::Exception;
 
 BEGIN {
@@ -74,6 +74,14 @@
     } '... we can change/add lazy as an attribute option';    
 
     ::lives_ok {
+        has '+foo' => ( metaclass => 'DoNotSerialize' ); 
+    } 'Can add metaclass attribute option';
+
+    ::lives_ok {
+        has '+foo' => ( traits => [ 'DoNotSerialize' ] );
+    } 'Can add traits attribute option';
+    
+    ::lives_ok {
         has '+bunch_of_stuff' => (isa => 'ArrayRef[Int]');        
     } '... extend an attribute with parameterized type';
     
@@ -105,7 +113,7 @@
     ::dies_ok { 
         has '+other_fail' => (isa => 'WangDoodle');           
     } '... cannot create an attribute with a non-existent type';       
-    
+
 }
 
 my $foo = Foo->new;
diff -ur Moose-0.40.orig/t/020_attributes/016_attribute_traits_registered.t Moose-0.40/t/020_attributes/016_attribute_traits_registered.t
--- Moose-0.40.orig/t/020_attributes/016_attribute_traits_registered.t	2008-04-14 19:27:05.000000000 +0100
+++ Moose-0.40/t/020_attributes/016_attribute_traits_registered.t	2008-04-16 20:11:33.000000000 +0100
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 6;
+use Test::More tests => 8;
 use Test::Exception;
 use Test::Moose;
 
@@ -30,6 +30,25 @@
 }
 
 {
+    package My::Other::Attribute::Trait;
+    use Moose::Role;
+    
+    has 'fnar' => (is => 'rw', isa => 'Str');
+    
+    after 'install_accessors' => sub {
+        my $self = shift;
+        $self->associated_class->add_method(
+            $self->fnar, 
+            $self->get_read_method_ref
+        );
+    };
+    
+    package Moose::Meta::Attribute::Custom::Trait::Other;
+    sub register_implementation { 'My::Other::Attribute::Trait' }
+}
+
+
+{
     package My::Class;
     use Moose;
     
@@ -41,6 +60,17 @@
     );
 }
 
+{   
+    package My::Derived::Class;
+    use Moose;
+
+    extends 'My::Class';
+
+    has '+bar' => (
+        traits => [qw/Other/],
+    );
+}
+
 my $c = My::Class->new(bar => 100);
 isa_ok($c, 'My::Class');
 
@@ -50,3 +80,9 @@
 is($c->baz, 100, '... got the right value for baz');
 
 does_ok($c->meta->get_attribute('bar'), 'My::Attribute::Trait');
+
+my $quux = My::Derived::Class(bar => 1000);
+
+ok($c->meta->get_attribute('bar')->does('My::Other::Attribute::Trait'));
+ok($c->meta->get_attribute('bar')->does('My::Attribute::Trait'));
+