Apply a patch to support handle => sub { ... }, contributed by Frank Cuny.

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

diff --git a/lib/Mouse/Meta/Attribute.pm b/lib/Mouse/Meta/Attribute.pm
index 0a12d95..61e9dba 100644 (file)
--- a/lib/Mouse/Meta/Attribute.pm
+++ b/lib/Mouse/Meta/Attribute.pm
@@ -5,9 +5,6 @@ use Carp ();
 
 use Mouse::Meta::TypeConstraint;
 
-#use Mouse::Meta::Method::Accessor;
-use Mouse::Meta::Method::Delegation;
-
 sub _process_options{
     my($class, $name, $args) = @_;
 
@@ -202,8 +199,7 @@ sub canonicalize_args{ # DEPRECATED
     my ($self, $name, %args) = @_;
 
     Carp::cluck("$self->canonicalize_args has been deprecated."
-        . "Use \$self->_process_options instead.")
-            if Mouse::Util::_MOUSE_VERBOSE;
+        . "Use \$self->_process_options instead.");
 
     return %args;
 }
@@ -212,8 +208,7 @@ sub create { # DEPRECATED
     my ($self, $class, $name, %args) = @_;
 
     Carp::cluck("$self->create has been deprecated."
-        . "Use \$meta->add_attribute and \$attr->install_accessors instead.")
-            if Mouse::Util::_MOUSE_VERBOSE;
+        . "Use \$meta->add_attribute and \$attr->install_accessors instead.");
 
     # noop
     return $self;
@@ -241,13 +236,17 @@ sub verify_against_type_constraint {
     return 1 if !$type_constraint;
     return 1 if $type_constraint->check($value);
 
-    $self->verify_type_constraint_error($self->name, $value, $type_constraint);
+    $self->_throw_type_constraint_error($value, $type_constraint);
 }
 
-sub verify_type_constraint_error {
-    my($self, $name, $value, $type) = @_;
-    $self->throw_error("Attribute ($name) does not pass the type constraint because: "
-        . $type->get_message($value));
+sub _throw_type_constraint_error {
+    my($self, $value, $type) = @_;
+
+    $self->throw_error(
+        sprintf q{Attribute (%s) does not pass the type constraint because: %s},
+            $self->name,
+            $type->get_message($value),
+    );
 }
 
 sub coerce_constraint { # DEPRECATED
@@ -281,8 +280,7 @@ sub clone_parent { # DEPRECATED
     my %args  = ($self->get_parent_args($class, $name), @_);
 
     Carp::cluck("$self->clone_parent has been deprecated."
-        . "Use \$meta->add_attribute and \$attr->install_accessors instead.")
-        if Mouse::Util::_MOUSE_VERBOSE;
+        . "Use \$meta->add_attribute and \$attr->install_accessors instead.");
 
     $self->clone_and_inherited_args($class, $name, %args);
 }
@@ -361,39 +359,12 @@ sub clear_value {
 }
 
 
-sub _canonicalize_handles {
-    my($self, $handles) = @_;
-
-    if (ref($handles) eq 'HASH') {
-        return %$handles;
-    }
-    elsif (ref($handles) eq 'ARRAY') {
-        return map { $_ => $_ } @$handles;
-    }
-    elsif (ref($handles) eq 'Regexp') {
-        my $class_or_role = ($self->{isa} || $self->{does})
-            || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)");
-
-        my $meta = Mouse::Meta::Class->initialize("$class_or_role"); # "" for stringify
-        return map  { $_ => $_ }
-               grep { !Mouse::Object->can($_) && $_ =~ $handles }
-                   Mouse::Util::is_a_metarole($meta)
-                        ? $meta->get_method_list
-                        : $meta->get_all_method_names;
-    }
-    else {
-        $self->throw_error("Unable to canonicalize the 'handles' option with $handles");
-    }
-}
-
 sub associate_method{
     my ($attribute, $method_name) = @_;
     $attribute->{associated_methods}++;
     return;
 }
 
-sub delegation_metaclass() { 'Mouse::Meta::Method::Delegation' }
-
 sub install_accessors{
     my($attribute) = @_;
 
@@ -411,16 +382,14 @@ sub install_accessors{
 
     # install delegation
     if(exists $attribute->{handles}){
-        my $delegation_class = $attribute->delegation_metaclass;
         my %handles = $attribute->_canonicalize_handles($attribute->{handles});
-        my $reader  = $attribute->get_read_method_ref;
 
-        while(my($handle_name, $method_to_call) = each %handles){
-            my $code = $delegation_class->_generate_delegation($attribute, $metaclass,
-                $reader, $handle_name, $method_to_call);
+        while(my($handle, $method_to_call) = each %handles){
+            $metaclass->add_method($handle =>
+                $attribute->_make_delegation_method(
+                    $handle, $method_to_call));
 
-            $metaclass->add_method($handle_name => $code);
-            $attribute->associate_method($handle_name);
+            $attribute->associate_method($handle);
         }
     }
 
@@ -432,6 +401,46 @@ sub install_accessors{
     return;
 }
 
+sub delegation_metaclass() { 'Mouse::Meta::Method::Delegation' }
+
+sub _canonicalize_handles {
+    my($self, $handles) = @_;
+
+    if (ref($handles) eq 'HASH') {
+        return %$handles;
+    }
+    elsif (ref($handles) eq 'ARRAY') {
+        return map { $_ => $_ } @$handles;
+    }
+    elsif ( ref($handles) eq 'CODE' ) {
+        my $class_or_role = ( $self->{isa} || $self->{does} )
+            || $self->throw_error( "Cannot find delegate metaclass for attribute " . $self->name );
+        return $handles->( $self, Mouse::Meta::Class->initialize("$class_or_role"));
+    }
+    elsif (ref($handles) eq 'Regexp') {
+        my $class_or_role = ($self->{isa} || $self->{does})
+            || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)");
+
+        my $meta = Mouse::Meta::Class->initialize("$class_or_role"); # "" for stringify
+        return map  { $_ => $_ }
+               grep { !Mouse::Object->can($_) && $_ =~ $handles }
+                   Mouse::Util::is_a_metarole($meta)
+                        ? $meta->get_method_list
+                        : $meta->get_all_method_names;
+    }
+    else {
+        $self->throw_error("Unable to canonicalize the 'handles' option with $handles");
+    }
+}
+
+sub _make_delegation_method {
+    my($self, $handle, $method_to_call) = @_;
+    my $delegator = $self->delegation_metaclass;
+    Mouse::Util::load_class($delegator);
+
+    return $delegator->_generate_delegation($self, $handle, $method_to_call);
+}
+
 sub throw_error{
     my $self = shift;
 
@@ -448,7 +457,7 @@ Mouse::Meta::Attribute - The Mouse attribute metaclass
 
 =head1 VERSION
 
-This document describes Mouse version 0.44
+This document describes Mouse version 0.4501
 
 =head1 METHODS