inherited-slot-specifications

diff --git a/lib/Moose.pm b/lib/Moose.pm
index ed64f64..2087c26 100644 (file)
--- a/lib/Moose.pm
+++ b/lib/Moose.pm
@@ -79,7 +79,13 @@ use Moose::Util::TypeConstraints;
             return subname 'Moose::has' => sub {
                 my ($name, %options) = @_;
                 if ($name =~ /^\+(.*)/) {
-                    warn $1;
+                    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);
+                    $meta->add_attribute($new_attr);
                 }
                 else {
                     if ($options{metaclass}) {

diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index fec33d7..4cab769 100644 (file)
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -28,26 +28,37 @@ __PACKAGE__->meta->add_attribute('trigger' => (
 
 sub new {
        my ($class, $name, %options) = @_;
-       
-       if (exists $options{is}) {
-               if ($options{is} eq 'ro') {
-                       $options{reader} = $name;
-                       (!exists $options{trigger})
+       $class->_process_options($name, \%options);
+       $class->SUPER::new($name, %options);    
+}
+
+sub clone {
+       my ($self, %options) = @_;
+       $self->_process_options($self->name, \%options);
+       $self->SUPER::clone(%options);  
+}
+
+sub _process_options {
+    my ($class, $name, $options) = @_;
+       if (exists $options->{is}) {
+               if ($options->{is} eq 'ro') {
+                       $options->{reader} = $name;
+                       (!exists $options->{trigger})
                            || confess "Cannot have a trigger on a read-only attribute";
                }
-               elsif ($options{is} eq 'rw') {
-                       $options{accessor} = $name;                             
-                       ((reftype($options{trigger}) || '') eq 'CODE')
+               elsif ($options->{is} eq 'rw') {
+                       $options->{accessor} = $name;                           
+                       ((reftype($options->{trigger}) || '') eq 'CODE')
                            || confess "A trigger must be a CODE reference"
-                               if exists $options{trigger};                    
+                               if exists $options->{trigger};                  
                }                       
        }
        
-       if (exists $options{isa}) {
+       if (exists $options->{isa}) {
            
-           if (exists $options{does}) {
-               if (eval { $options{isa}->can('does') }) {
-                   ($options{isa}->does($options{does}))                   
+           if (exists $options->{does}) {
+               if (eval { $options->{isa}->can('does') }) {
+                   ($options->{isa}->does($options->{does}))               
                        || confess "Cannot have an isa option and a does option if the isa does not do the does";
                }
                else {
@@ -56,69 +67,67 @@ sub new {
            }       
            
            # allow for anon-subtypes here ...
-           if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
-                       $options{type_constraint} = $options{isa};
+           if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
+                       $options->{type_constraint} = $options->{isa};
                }
                else {
                    
-                   if ($options{isa} =~ /\|/) {
-                       my @type_constraints = split /\s*\|\s*/ => $options{isa};
-                       $options{type_constraint} = Moose::Util::TypeConstraints::create_type_constraint_union(
+                   if ($options->{isa} =~ /\|/) {
+                       my @type_constraints = split /\s*\|\s*/ => $options->{isa};
+                       $options->{type_constraint} = Moose::Util::TypeConstraints::create_type_constraint_union(
                            @type_constraints
                        );
                    }
                    else {
                    # otherwise assume it is a constraint
-                   my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa});     
+                   my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{isa});           
                    # if the constraing it not found ....
                    unless (defined $constraint) {
                        # assume it is a foreign class, and make 
                        # an anon constraint for it 
                        $constraint = Moose::Util::TypeConstraints::subtype(
                            'Object', 
-                           Moose::Util::TypeConstraints::where { $_->isa($options{isa}) }
+                           Moose::Util::TypeConstraints::where { $_->isa($options->{isa}) }
                        );
                    }                       
-                $options{type_constraint} = $constraint;
+                $options->{type_constraint} = $constraint;
             }
                }
        }       
-       elsif (exists $options{does}) {     
+       elsif (exists $options->{does}) {           
            # allow for anon-subtypes here ...
-           if (blessed($options{does}) && $options{does}->isa('Moose::Meta::TypeConstraint')) {
-                       $options{type_constraint} = $options{isa};
+           if (blessed($options->{does}) && $options->{does}->isa('Moose::Meta::TypeConstraint')) {
+                       $options->{type_constraint} = $options->{isa};
                }
                else {
                    # otherwise assume it is a constraint
-                   my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options{does});              
+                   my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options->{does});            
                    # if the constraing it not found ....
                    unless (defined $constraint) {                              
                        # assume it is a foreign class, and make 
                        # an anon constraint for it 
                        $constraint = Moose::Util::TypeConstraints::subtype(
                            'Role', 
-                           Moose::Util::TypeConstraints::where { $_->does($options{does}) }
+                           Moose::Util::TypeConstraints::where { $_->does($options->{does}) }
                        );
                    }                       
-            $options{type_constraint} = $constraint;
+            $options->{type_constraint} = $constraint;
                }           
        }
        
-       if (exists $options{coerce} && $options{coerce}) {
-           (exists $options{type_constraint})
+       if (exists $options->{coerce} && $options->{coerce}) {
+           (exists $options->{type_constraint})
                || confess "You cannot have coercion without specifying a type constraint";
-           (!$options{type_constraint}->isa('Moose::Meta::TypeConstraint::Union'))
+           (!$options->{type_constraint}->isa('Moose::Meta::TypeConstraint::Union'))
                || confess "You cannot have coercion with a type constraint union";             
         confess "You cannot have a weak reference to a coerced value"
-            if $options{weak_ref};             
+            if $options->{weak_ref};           
        }       
        
-       if (exists $options{lazy} && $options{lazy}) {
-           (exists $options{default})
+       if (exists $options->{lazy} && $options->{lazy}) {
+           (exists $options->{default})
                || confess "You cannot have lazy attribute without specifying a default value for it";      
-       }
-       
-       $class->SUPER::new($name, %options);    
+       }    
 }
 
 sub initialize_instance_slot {
@@ -271,6 +280,8 @@ will behave just as L<Class::MOP::Attribute> does.
 
 =item B<new>
 
+=item B<clone>
+
 =item B<initialize_instance_slot>
 
 =item B<generate_accessor_method>

diff --git a/t/038_attribute_inherited_slot_specs.t b/t/038_attribute_inherited_slot_specs.t
new file mode 100644 (file)
index 0000000..df735b2
--- /dev/null
+++ b/t/038_attribute_inherited_slot_specs.t
@@ -0,0 +1,66 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 10;
+use Test::Exception;
+
+BEGIN {
+    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;
+    
+    has 'bar' => (is => 'ro', isa => 'Str', default => 'Foo::bar');
+    
+    package Bar;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    extends 'Foo';
+    
+    has '+bar' => (default => 'Bar::bar');  
+}
+
+my $foo = Foo->new;
+isa_ok($foo, 'Foo');
+
+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;
+isa_ok($bar, 'Bar');
+isa_ok($bar, 'Foo');
+
+is($bar->bar, 'Bar::bar', '... got the right default value');
+
+dies_ok { $bar->bar(10) } '... Bar::bar is a read/only attr';
+
+# check some meta-stuff
+
+ok(Bar->meta->has_attribute('bar'), '... Bar has a bar attr');
+isnt(Foo->meta->get_attribute('bar'), 
+     Bar->meta->get_attribute('bar'), 
+     '... Foo and Bar have different copies of bar');
+
+
+
+
+
+
+
+
+