Inherited attributes may now be extended without restriction

[gitmo/Moose.git] / lib / Moose / Meta / Attribute.pm

diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index 15064d9..0083957 100644 (file)
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -9,7 +9,7 @@ use Carp         'confess';
 use Sub::Name    'subname';
 use overload     ();
 
-our $VERSION   = '0.18';
+our $VERSION   = '0.22';
 our $AUTHORITY = 'cpan:STEVAN';
 
 use Moose::Meta::Method::Accessor;
@@ -47,6 +47,14 @@ __PACKAGE__->meta->add_attribute('documentation' => (
     predicate => 'has_documentation',
 ));
 
+# NOTE:
+# we need to have a ->does method in here to 
+# more easily support traits, and the introspection 
+# of those traits. So in order to do this we 
+# just alias Moose::Object's version of it.
+# - SL
+*does = \&Moose::Object::does;
+
 sub new {
     my ($class, $name, %options) = @_;
     $class->_process_options($name, \%options);
@@ -57,23 +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};
-    }
-
-    # 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')) {
@@ -86,14 +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
-        ($type_constraint->is_subtype_of($self->type_constraint->name))
-            || confess "New type constraint setting must be a subtype of inherited one"
-                # 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};
     }
@@ -261,6 +252,45 @@ sub initialize_instance_slot {
 
 ## Slot management
 
+# FIXME:
+# this duplicates too much code from 
+# Class::MOP::Attribute, we need to 
+# refactor these bits eventually.
+# - SL
+sub _set_initial_slot_value {
+    my ($self, $meta_instance, $instance, $value) = @_;
+
+    my $slot_name = $self->name;
+
+    return $meta_instance->set_slot_value($instance, $slot_name, $value)
+        unless $self->has_initializer;
+
+    my ($type_constraint, $can_coerce);
+    if ($self->has_type_constraint) {
+        $type_constraint = $self->type_constraint;
+        $can_coerce      = ($self->should_coerce && $type_constraint->has_coercion);
+    }
+
+    my $callback = sub {
+        my $val = shift;
+        if ($type_constraint) {
+            $val = $type_constraint->coerce($val)
+                if $can_coerce;
+            $type_constraint->check($val)
+                || confess "Attribute (" 
+                         . $slot_name 
+                         . ") does not pass the type constraint because: " 
+                         . $type_constraint->get_message($val);            
+        }
+        $meta_instance->set_slot_value($instance, $slot_name, $val);
+    };
+    
+    my $initializer = $self->initializer;
+
+    # most things will just want to set a value, so make it first arg
+    $instance->$initializer($value, $callback, $self);
+}
+
 sub set_value {
     my ($self, $instance, $value) = @_;
 
@@ -398,13 +428,22 @@ sub install_accessors {
                 $associated_class->add_method($handle => subname $name, $method_to_call);
             }
             else {
+                # NOTE:
+                # we used to do a goto here, but the
+                # goto didn't handle failure correctly
+                # (it just returned nothing), so I took 
+                # that out. However, the more I thought
+                # about it, the less I liked it doing 
+                # the goto, and I prefered the act of 
+                # delegation being actually represented
+                # in the stack trace. 
+                # - SL
                 $associated_class->add_method($handle => subname $name, sub {
                     my $proxy = (shift)->$accessor();
-                    @_ = ($proxy, @_);
                     (defined $proxy) 
                         || confess "Cannot delegate $handle to $method_to_call because " . 
                                    "the value of " . $self->name . " is not defined";
-                    goto &{ $proxy->can($method_to_call) || return };
+                    $proxy->$method_to_call(@_);
                 });
             }
         }
@@ -524,6 +563,8 @@ will behave just as L<Class::MOP::Attribute> does.
 
 =item B<new>
 
+=item B<does>
+
 =item B<initialize_instance_slot>
 
 =item B<install_accessors>