fixed

diff --git a/lib/Moose.pm b/lib/Moose.pm
index cd70131..9365583 100644 (file)
--- a/lib/Moose.pm
+++ b/lib/Moose.pm
@@ -82,9 +82,7 @@ use Moose::Util::TypeConstraints;
                     my $inherited_attr = $meta->find_attribute_by_name($1);
                     (defined $inherited_attr)
                         || confess "Could not find an attribute by the name of '$1' to inherit from";
-                    #(scalar keys %options == 1 && exists $options{default})
-                    #    || confess "Inherited slot specifications can only alter the 'default' option";
-                    my $new_attr = $inherited_attr->clone(%options);
+                    my $new_attr = $inherited_attr->clone_and_inherit_options(%options);
                     $meta->add_attribute($new_attr);
                 }
                 else {

diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index 1d9632a..9173ca1 100644 (file)
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -32,10 +32,37 @@ sub new {
        $class->SUPER::new($name, %options);    
 }
 
-sub clone {
-       my ($self, %options) = @_;
-       $self->_process_options($self->name, \%options);
-       $self->SUPER::clone(%options);  
+sub clone_and_inherit_options {
+    my ($self, %options) = @_;
+    # you can change default, required and coerce 
+    my %actual_options;
+    foreach my $legal_option (qw(default coerce required)) {
+        if (exists $options{$legal_option}) {
+            $actual_options{$legal_option} = $options{$legal_option};
+            delete $options{$legal_option};
+        }
+    }
+    # 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')) {
+                       $type_constraint = $options{isa};
+               }        
+               else {
+                   $type_constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa});
+                   (defined $type_constraint)
+                       || confess "Could not find the type constraint '" . $options{isa} . "'";
+               }
+               ($type_constraint->is_subtype_of($self->type_constraint->name))
+                   || confess "New type constraint setting must be a subtype of inherited one"
+                       if $self->has_type_constraint;
+               $actual_options{type_constraint} = $type_constraint;
+        delete $options{isa};
+    }
+    (scalar keys %options == 0) 
+        || confess "Illegal inherited options => (" . (join ', ' => keys %options) . ")";
+    $self->clone(%actual_options);
 }
 
 sub _process_options {
@@ -280,7 +307,7 @@ will behave just as L<Class::MOP::Attribute> does.
 
 =item B<new>
 
-=item B<clone>
+=item B<clone_and_inherit_options>
 
 =item B<initialize_instance_slot>
 

diff --git a/t/038_attribute_inherited_slot_specs.t b/t/038_attribute_inherited_slot_specs.t
index 657a78f..f1503ba 100644 (file)
--- a/t/038_attribute_inherited_slot_specs.t
+++ b/t/038_attribute_inherited_slot_specs.t
@@ -3,26 +3,37 @@
 use strict;
 use warnings;
 
-use Test::More tests => 12;
+use Test::More tests => 57;
 use Test::Exception;
 
 BEGIN {
-    use_ok('Moose');           
+    use_ok('Moose');  
 }
 
-=pod
-
-http://www.gwydiondylan.org/books/drm/Instance_Creation_and_Initialization#HEADING43-37
-
-=cut
-
 {
     package Foo;
     use strict;
     use warnings;
     use Moose;
+    use Moose::Util::TypeConstraints;
+    
+    subtype 'FooStr' 
+        => as 'Str'
+        => where { /Foo/ };
+        
+    coerce 'FooStr' 
+        => from ArrayRef
+            => via { 'FooArrayRef' };
     
     has 'bar' => (is => 'ro', isa => 'Str', default => 'Foo::bar');
+    has 'baz' => (is => 'rw', isa => 'Ref');   
+    has 'foo' => (is => 'rw', isa => 'FooStr');       
+    
+    has 'gorch' => (is => 'ro');        
+    
+    # this one will work here ....
+    has 'fail' => (isa => 'CodeRef');
+    has 'other_fail';    
     
     package Bar;
     use strict;
@@ -32,34 +43,138 @@ http://www.gwydiondylan.org/books/drm/Instance_Creation_and_Initialization#HEADI
     extends 'Foo';
     
     has '+bar' => (default => 'Bar::bar');  
+    has '+baz' => (isa     => 'ArrayRef');        
+    
+    has '+foo'   => (coerce   => 1);    
+    has '+gorch' => (required => 1); 
+    
+    # this one will *not* work here ....
+    ::dies_ok { 
+        has '+fail' => (isa => 'Ref');           
+    } '... cannot create an attribute with an improper subtype relation';    
+    ::dies_ok { 
+        has '+other_fail' => (trigger => sub {});           
+    } '... cannot create an attribute with an illegal option';    
+    ::dies_ok { 
+        has '+other_fail' => (weak_ref => 1);           
+    } '... cannot create an attribute with an illegal option';    
+    ::dies_ok { 
+        has '+other_fail' => (lazy => 1);           
+    } '... cannot create an attribute with an illegal option';    
+    
 }
 
 my $foo = Foo->new;
 isa_ok($foo, 'Foo');
 
-is($foo->bar, 'Foo::bar', '... got the right default value');
+is($foo->foo, undef, '... got the right undef default value');
+lives_ok { $foo->foo('FooString') } '... assigned foo correctly';
+is($foo->foo, 'FooString', '... got the right value for foo');
 
+dies_ok { $foo->foo([]) } '... foo is not coercing (as expected)';
+
+is($foo->bar, 'Foo::bar', '... got the right default value');
 dies_ok { $foo->bar(10) } '... Foo::bar is a read/only attr';
 
-my $bar = Bar->new;
+is($foo->baz, undef, '... got the right undef default value');
+
+{
+    my $hash_ref = {};
+    lives_ok { $foo->baz($hash_ref) } '... Foo::baz accepts hash refs';
+    is($foo->baz, $hash_ref, '... got the right value assigned to baz');
+    
+    my $array_ref = [];
+    lives_ok { $foo->baz($array_ref) } '... Foo::baz accepts an array ref';
+    is($foo->baz, $array_ref, '... got the right value assigned to baz');
+
+    my $scalar_ref = \(my $var);
+    lives_ok { $foo->baz($scalar_ref) } '... Foo::baz accepts scalar ref';
+    is($foo->baz, $scalar_ref, '... got the right value assigned to baz');
+    
+    my $code_ref = sub { 1 };
+    lives_ok { $foo->baz($code_ref) } '... Foo::baz accepts a code ref';
+    is($foo->baz, $code_ref, '... got the right value assigned to baz');    
+}
+
+dies_ok {
+    Bar->new;
+} '... cannot create Bar without required gorch param';
+
+my $bar = Bar->new(gorch => 'Bar::gorch');
 isa_ok($bar, 'Bar');
 isa_ok($bar, 'Foo');
 
-is($bar->bar, 'Bar::bar', '... got the right default value');
+is($bar->foo, undef, '... got the right undef default value');
+lives_ok { $bar->foo('FooString') } '... assigned foo correctly';
+is($bar->foo, 'FooString', '... got the right value for foo');
+lives_ok { $bar->foo([]) } '... assigned foo correctly';
+is($bar->foo, 'FooArrayRef', '... got the right value for foo');
+
+is($bar->gorch, 'Bar::gorch', '... got the right default value');
 
+is($bar->bar, 'Bar::bar', '... got the right default value');
 dies_ok { $bar->bar(10) } '... Bar::bar is a read/only attr';
 
+is($bar->baz, undef, '... got the right undef default value');
+
+{
+    my $hash_ref = {};
+    dies_ok { $bar->baz($hash_ref) } '... Bar::baz does not accept hash refs';
+    
+    my $array_ref = [];
+    lives_ok { $bar->baz($array_ref) } '... Bar::baz can accept an array ref';
+    is($bar->baz, $array_ref, '... got the right value assigned to baz');
+
+    my $scalar_ref = \(my $var);
+    dies_ok { $bar->baz($scalar_ref) } '... Bar::baz does not accept a scalar ref';
+    
+    my $code_ref = sub { 1 };
+    dies_ok { $bar->baz($code_ref) } '... Bar::baz does not accept a code ref';
+}
+
 # check some meta-stuff
 
+ok(Bar->meta->has_attribute('foo'), '... Bar has a foo attr');
 ok(Bar->meta->has_attribute('bar'), '... Bar has a bar attr');
+ok(Bar->meta->has_attribute('baz'), '... Bar has a baz attr');
+ok(Bar->meta->has_attribute('gorch'), '... Bar has a gorch 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');
+
+isnt(Foo->meta->get_attribute('foo'), 
+     Bar->meta->get_attribute('foo'), 
+     '... Foo and Bar have different copies of foo');
 isnt(Foo->meta->get_attribute('bar'), 
      Bar->meta->get_attribute('bar'), 
      '... Foo and Bar have different copies of bar');
-
+isnt(Foo->meta->get_attribute('baz'), 
+     Bar->meta->get_attribute('baz'), 
+     '... Foo and Bar have different copies of baz');          
+isnt(Foo->meta->get_attribute('gorch'), 
+     Bar->meta->get_attribute('gorch'), 
+     '... Foo and Bar have different copies of gorch');     
+     
 ok(Bar->meta->get_attribute('bar')->has_type_constraint, 
    '... Bar::bar inherited the type constraint too');
+ok(Bar->meta->get_attribute('baz')->has_type_constraint, 
+  '... Bar::baz inherited the type constraint too');   
 
 is(Bar->meta->get_attribute('bar')->type_constraint->name, 
    'Str', '... Bar::bar inherited the right type constraint too');
 
+is(Foo->meta->get_attribute('baz')->type_constraint->name, 
+  'Ref', '... Foo::baz inherited the right type constraint too');
+is(Bar->meta->get_attribute('baz')->type_constraint->name, 
+   'ArrayRef', '... Bar::baz inherited the right type constraint too');   
+   
+ok(!Foo->meta->get_attribute('gorch')->is_required, 
+  '... Foo::gorch is not a required attr');
+ok(Bar->meta->get_attribute('gorch')->is_required, 
+   '... Bar::gorch is a required attr');
+   
+ok(!Foo->meta->get_attribute('foo')->should_coerce, 
+  '... Foo::foo should not coerce');
+ok(Bar->meta->get_attribute('foo')->should_coerce, 
+   '... Bar::foo should coerce');    
+