X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FAttribute.pm;h=0ebc1b8602281431352739896d94048862026d43;hb=113d3174264db82cb788bc846f617584072cba39;hp=7f76bc37237cb2e8c239d60ec24c61fb00583c6c;hpb=70a69dd18fb75bd1ada6e8067ea1a3e50d1546d0;p=gitmo%2FMoose.git

diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index 7f76bc3..0ebc1b8 100644
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -7,7 +7,7 @@ use warnings;
 use Scalar::Util 'blessed', 'weaken';
 use overload     ();
 
-our $VERSION   = '0.83';
+our $VERSION   = '0.91';
 our $AUTHORITY = 'cpan:STEVAN';
 
 use Moose::Meta::Method::Accessor;
@@ -40,6 +40,7 @@ __PACKAGE__->meta->add_attribute('trigger' => (
 ));
 __PACKAGE__->meta->add_attribute('handles' => (
     reader    => 'handles',
+    writer    => '_set_handles',
     predicate => 'has_handles',
 ));
 __PACKAGE__->meta->add_attribute('documentation' => (
@@ -77,28 +78,45 @@ sub throw_error {
 sub new {
     my ($class, $name, %options) = @_;
     $class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS
+    
+    delete $options{__hack_no_process_options};
+
+    my %attrs =
+        ( map { $_ => 1 }
+          grep { defined }
+          map { $_->init_arg() }
+          $class->meta()->get_all_attributes()
+        );
+
+    my @bad = sort grep { ! $attrs{$_} }  keys %options;
+
+    if (@bad)
+    {
+        Carp::cluck "Found unknown argument(s) passed to '$name' attribute constructor in '$class': @bad";
+    }
+
     return $class->SUPER::new($name, %options);
 }
 
 sub interpolate_class_and_new {
-    my ($class, $name, @args) = @_;
+    my ($class, $name, %args) = @_;
 
-    my ( $new_class, @traits ) = $class->interpolate_class(@args);
+    my ( $new_class, @traits ) = $class->interpolate_class(\%args);
 
-    $new_class->new($name, @args, ( scalar(@traits) ? ( traits => \@traits ) : () ) );
+    $new_class->new($name, %args, ( scalar(@traits) ? ( traits => \@traits ) : () ) );
 }
 
 sub interpolate_class {
-    my ($class, %options) = @_;
+    my ($class, $options) = @_;
 
     $class = ref($class) || $class;
 
-    if ( my $metaclass_name = delete $options{metaclass} ) {
+    if ( my $metaclass_name = delete $options->{metaclass} ) {
         my $new_class = Moose::Util::resolve_metaclass_alias( Attribute => $metaclass_name );
 
         if ( $class ne $new_class ) {
             if ( $new_class->can("interpolate_class") ) {
-                return $new_class->interpolate_class(%options);
+                return $new_class->interpolate_class($options);
             } else {
                 $class = $new_class;
             }
@@ -107,7 +125,7 @@ sub interpolate_class {
 
     my @traits;
 
-    if (my $traits = $options{traits}) {
+    if (my $traits = $options->{traits}) {
         my $i = 0;
         while ($i < @$traits) {
             my $trait = $traits->[$i++];
@@ -146,7 +164,7 @@ my @legal_options_for_inheritance = qw(
     documentation lazy handles
     builder type_constraint
     definition_context
-    lazy_build
+    lazy_build weak_ref
 );
 
 sub legal_options_for_inheritance { @legal_options_for_inheritance }
@@ -225,7 +243,7 @@ sub clone_and_inherit_options {
     # so we can ignore it for them.
     # - SL
     if ($self->can('interpolate_class')) {
-        ( $actual_options{metaclass}, my @traits ) = $self->interpolate_class(%options);
+        ( $actual_options{metaclass}, my @traits ) = $self->interpolate_class(\%options);
 
         my %seen;
         my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits;
@@ -244,7 +262,7 @@ sub clone_and_inherit_options {
 sub clone {
     my ( $self, %params ) = @_;
 
-    my $class = $params{metaclass} || ref $self;
+    my $class = delete $params{metaclass} || ref $self;
 
     my ( @init, @non_init );
 
@@ -478,6 +496,11 @@ sub set_value {
     my $meta_instance = Class::MOP::Class->initialize(blessed($instance))
                                          ->get_meta_instance;
 
+    my @old;
+    if ( $self->has_trigger && $self->has_value($instance) ) {
+        @old = $self->get_value($instance, 'for trigger');
+    }
+
     $meta_instance->set_slot_value($instance, $attr_name, $value);
 
     if (ref $value && $self->is_weak_ref) {
@@ -485,12 +508,12 @@ sub set_value {
     }
 
     if ($self->has_trigger) {
-        $self->trigger->($instance, $value);
+        $self->trigger->($instance, $value, @old);
     }
 }
 
 sub get_value {
-    my ($self, $instance) = @_;
+    my ($self, $instance, $for_trigger) = @_;
 
     if ($self->is_lazy) {
         unless ($self->has_value($instance)) {
@@ -507,7 +530,7 @@ sub get_value {
         }
     }
 
-    if ($self->should_auto_deref) {
+    if ( $self->should_auto_deref && ! $for_trigger ) {
 
         my $type_constraint = $self->type_constraint;
 
@@ -540,18 +563,39 @@ sub install_accessors {
     my $self = shift;
     $self->SUPER::install_accessors(@_);
     $self->install_delegation if $self->has_handles;
+    return;
+}
+
+sub _check_associated_methods {
+    my $self = shift;
     unless (
-        # XXX handles should be in associated_methods
-        $self->has_handles
-        || @{ $self->associated_methods }
+        @{ $self->associated_methods }
         || ($self->_is_metadata || '') eq 'bare'
     ) {
-        $self->throw_error(
-            'Attribute (' . $self->name . ') has no associated methods'
+        Carp::cluck(
+            'Attribute (' . $self->name . ') of class '
+            . $self->associated_class->name
+            . ' has no associated methods'
             . ' (did you mean to provide an "is" argument?)'
+            . "\n"
         )
     }
-    return;
+}
+
+sub _process_accessors {
+    my $self = shift;
+    my ($type, $accessor, $generate_as_inline_methods) = @_;
+    $accessor = (keys %$accessor)[0] if (ref($accessor)||'') eq 'HASH';
+    my $method = $self->associated_class->get_method($accessor);
+    if ($method && !$method->isa('Class::MOP::Method::Accessor')
+     && (!$self->definition_context
+      || $method->package_name eq $self->definition_context->{package})) {
+        Carp::cluck(
+            "You are overwriting a locally defined method ($accessor) with "
+          . "an accessor"
+        );
+    }
+    $self->SUPER::_process_accessors(@_);
 }
 
 sub remove_accessors {
@@ -595,6 +639,7 @@ sub install_delegation {
         my $method = $self->_make_delegation_method($handle, $method_to_call);
 
         $self->associated_class->add_method($method->name, $method);
+        $self->associate_method($method);
     }
 }
 
@@ -628,6 +673,9 @@ sub _canonicalize_handles {
         elsif ($handle_type eq 'CODE') {
             return $handles->($self, $self->_find_delegate_metaclass);
         }
+        elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::DuckType')) {
+            return map { $_ => $_ } @{ $handles->methods };
+        }
         else {
             $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
         }
@@ -639,10 +687,11 @@ sub _canonicalize_handles {
         (blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
             || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles);
 
-        return map { $_ => $_ } (
+        return map { $_ => $_ }
+            grep { $_ ne 'meta' } (
             $role_meta->get_method_list,
             map { $_->name } $role_meta->get_required_method_list,
-        );
+            );
     }
 }
 
@@ -688,11 +737,17 @@ sub _make_delegation_method {
     $method_body = $method_to_call
         if 'CODE' eq ref($method_to_call);
 
+    my @curried_arguments;
+
+    ($method_to_call, @curried_arguments) = @$method_to_call
+        if 'ARRAY' eq ref($method_to_call);
+
     return $self->delegation_metaclass->new(
         name               => $handle_name,
         package_name       => $self->associated_class->name,
         attribute          => $self,
         delegate_to_method => $method_to_call,
+        curried_arguments  => \@curried_arguments,
     );
 }
 
@@ -775,7 +830,7 @@ It adds the following options to the constructor:
 
 =over 8
 
-=item * is => 'ro' or 'rw'
+=item * is => 'ro', 'rw', 'bare'
 
 This provides a shorthand for specifying the C<reader>, C<writer>, or
 C<accessor> names. If the attribute is read-only ('ro') then it will
@@ -786,6 +841,11 @@ with the same name. If you provide an explicit C<writer> for a
 read-write attribute, then you will have a C<reader> with the same
 name as the attribute, and a C<writer> with the name you provided.
 
+Use 'bare' when you are deliberately not installing any methods
+(accessor, reader, etc.) associated with this attribute; otherwise,
+Moose will issue a deprecation warning when this attribute is added to a
+metaclass.
+
 =item * isa => $type
 
 This option accepts a type. The type can be a string, which should be