Inherited attributes may now be extended without restriction

diff --git a/Changes b/Changes
index d2d4cbf..6e18299 100644 (file)
--- a/Changes
+++ b/Changes
@@ -15,6 +15,10 @@ Revision history for Perl extension Moose
         found by Jesse Luehrs, fixed by Dave Rolsky)
         - added tests for this (Dave Rolsky)
 
+    * Moose::Meta::Attribute
+      - inherited attributes may now be extended without restriction on type
+        and some other attributes (Sartak)
+
 0.40 Fri. March 14, 2008
     - I hate Pod::Coverage
 

diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index 0cadb82..0083957 100644 (file)
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -65,31 +65,13 @@ sub clone_and_inherit_options {
     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 handles builder)) {
         if (exists $options{$legal_option}) {
             $actual_options{$legal_option} = $options{$legal_option};
             delete $options{$legal_option};
         }
     }
 
-    # handles can only be added, not changed
-    if ($options{handles}) {
-        confess "You can only add the 'handles' option, you cannot change it"
-            if $self->has_handles;
-        $actual_options{handles} = $options{handles};
-        delete $options{handles};
-    }
-    
-    # handles can only be added, not changed
-    if ($options{builder}) {
-        confess "You can only add the 'builder' option, you cannot change it"
-            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}) {
         my $type_constraint;
         if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
@@ -102,18 +84,7 @@ sub clone_and_inherit_options {
             (defined $type_constraint)
                 || confess "Could not find the type constraint '" . $options{isa} . "'";
         }
-        # NOTE:
-        # check here to see if the new type
-        # is a subtype of the old one
-        # or if the old one is a union and the
-        # subtype (or a supertype of it) is included
-        # in the union
-        $type_constraint->is_subtype_of($self->type_constraint->name)
-            || ($self->type_constraint->can('includes_type') && $self->type_constraint->includes_type($type_constraint))
-                || confess "New type constraint setting must be a subtype of inherited one" . ($self->type_constraint->can('includes_type') ? ", or included in the inherited constraint" : '')
-                    # iff we have a type constraint that is ...
-                    if $self->has_type_constraint;
-        # then we use it :)
+
         $actual_options{type_constraint} = $type_constraint;
         delete $options{isa};
     }

diff --git a/t/020_attributes/009_attribute_inherited_slot_specs.t b/t/020_attributes/009_attribute_inherited_slot_specs.t
index 2f1151f..4f9adde 100644 (file)
--- a/t/020_attributes/009_attribute_inherited_slot_specs.t
+++ b/t/020_attributes/009_attribute_inherited_slot_specs.t
@@ -81,9 +81,9 @@ BEGIN {
         has '+one_last_one' => (isa => subtype('Ref', where { blessed $_ eq 'CODE' }));        
     } '... extend an attribute with anon-subtype';    
     
-    ::dies_ok {
+    ::lives_ok {
         has '+one_last_one' => (isa => 'Value');        
-    } '... cannot extend an attribute with a non-subtype';    
+    } '... now can extend an attribute with a non-subtype';    
     
     ::lives_ok {
         has '+bling' => (handles => ['hello']);        
@@ -93,9 +93,9 @@ BEGIN {
     ::dies_ok {
         has '+blang' => (handles => ['hello']);        
     } '... we can not alter the handles attribute option';    
-    ::dies_ok { 
+    ::lives_ok { 
         has '+fail' => (isa => 'Ref');           
-    } '... cannot create an attribute with an improper subtype relation';    
+    } '... can now create an attribute with an improper subtype relation';    
     ::dies_ok { 
         has '+other_fail' => (trigger => sub {});           
     } '... cannot create an attribute with an illegal option';    
@@ -193,8 +193,8 @@ ok(Bar->meta->has_attribute('gloum'), '... Bar has a gloum attr');
 ok(Bar->meta->has_attribute('bling'), '... Bar has a bling attr');
 ok(Bar->meta->has_attribute('bunch_of_stuff'), '... Bar does have a bunch_of_stuff attr');
 ok(!Bar->meta->has_attribute('blang'), '... Bar has a blang attr');
-ok(!Bar->meta->has_attribute('fail'), '... Bar does not have a fail attr');
-ok(!Bar->meta->has_attribute('other_fail'), '... Bar does not have a fail attr');
+ok(Bar->meta->has_attribute('fail'), '... Bar has a fail attr');
+ok(!Bar->meta->has_attribute('other_fail'), '... Bar does not have an other_fail attr');
 
 isnt(Foo->meta->get_attribute('foo'), 
      Bar->meta->get_attribute('foo'), 

diff --git a/t/030_roles/017_extending_role_attrs.t b/t/030_roles/017_extending_role_attrs.t
index 35138b6..2cb8c11 100644 (file)
--- a/t/030_roles/017_extending_role_attrs.t
+++ b/t/030_roles/017_extending_role_attrs.t
@@ -150,27 +150,27 @@ is_deeply($quux->quux, ["hi"], "... still has the old ArrayRef value");
     package Err::Role;
     use Moose::Role;
 
-    has "err" => (
-        isa => 'Str | Int',
-    );
+    for (1..3) {
+        has "err$_" => (
+            isa => 'Str | Int',
+        );
+    }
 
     package Err;
     use Moose;
 
     with 'Err::Role';
 
-    my $error = qr/New type constraint setting must be a subtype of inherited one, or included in the inherited constraint/;
-
-    ::throws_ok {
-        has '+err' => (isa => 'Defined');
-    } $error, "must get more specific, not less specific";
+    ::lives_ok {
+        has '+err1' => (isa => 'Defined');
+    } "can get less specific in the subclass";
 
-    ::throws_ok {
-        has '+err' => (isa => 'Bool');
-    } $error, "the type has to be a part of the union";
+    ::lives_ok {
+        has '+err2' => (isa => 'Bool');
+    } "or change the type completely";
 
-    ::throws_ok {
-        has '+err' => (isa => 'Str | ArrayRef');
-    } $error, "can't add new types to the union";
+    ::lives_ok {
+        has '+err3' => (isa => 'Str | ArrayRef');
+    } "or add new types to the union";
 }