From: Piers Cawley <pdcawley@bofh.org.uk>
Date: Sat, 16 Jan 2010 04:25:30 +0000 (+0000)
Subject: Made the delegation closure have useful error trace information.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=refs%2Fheads%2Fabandoned%2Fname-delegations;p=gitmo%2FMoose.git

Made the delegation closure have useful error trace information.
Extended the test suite to make sure the inlining works as well.
---

diff --git a/Changes b/Changes
index 3f363b4..afb20ec 100644
--- a/Changes
+++ b/Changes
@@ -8,6 +8,11 @@ for, noteworthy changes.
   * Moose::Object now has stubs for BUILD and DEMOLISH, so they can be safely
     wrapped in roles without needing to provide your own stubs. (doy)
 
+  * Moose::Meta::Method::Delegation 
+  * Moose::Meta::Attribute
+    - Delegations are now inlined on make_immutable and have file/line set
+      to the point at which the delegation was defined. (pdcawley)
+
 0.94 Mon, Jan 18, 2010
 
   [API CHANGES]
diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index 282341d..632da02 100644
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -542,7 +542,7 @@ sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
 sub install_accessors {
     my $self = shift;
     $self->SUPER::install_accessors(@_);
-    $self->install_delegation if $self->has_handles;
+    $self->install_delegation(@_);
     return;
 }
 
@@ -587,6 +587,9 @@ sub remove_accessors {
 
 sub install_delegation {
     my $self = shift;
+    my $inline = shift;
+
+    return unless $self->has_handles;
 
     # NOTE:
     # Here we canonicalize the 'handles' option
@@ -603,8 +606,12 @@ sub install_delegation {
         my $class_name = $associated_class->name;
         my $name = "${class_name}::${handle}";
 
-            (!$associated_class->has_method($handle))
-                || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle);
+        if ($associated_class->has_method($handle)) {
+            $self->throw_error(
+                "You cannot overwrite a locally defined method ($handle) with a delegation",
+                method_name => $handle
+            ) unless $inline;
+        }
 
         # NOTE:
         # handles is not allowed to delegate
@@ -616,7 +623,7 @@ sub install_delegation {
         #cluck("Not delegating method '$handle' because it is a core method") and
         next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
 
-        my $method = $self->_make_delegation_method($handle, $method_to_call);
+        my $method = $self->_make_delegation_method($handle, $method_to_call, $inline);
 
         $self->associated_class->add_method($method->name, $method);
         $self->associate_method($method);
@@ -713,7 +720,7 @@ sub _get_delegate_method_list {
 sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
 
 sub _make_delegation_method {
-    my ( $self, $handle_name, $method_to_call ) = @_;
+    my ( $self, $handle_name, $method_to_call, $is_inline ) = @_;
 
     my @curried_arguments;
 
@@ -726,6 +733,7 @@ sub _make_delegation_method {
         attribute          => $self,
         delegate_to_method => $method_to_call,
         curried_arguments  => \@curried_arguments,
+        is_inline          => $is_inline,
     );
 }
 
diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index cfe57b8..51c5854 100644
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -102,11 +102,27 @@ sub _immutable_options {
 
         # Moose always does this when an attribute is created
         inline_accessors => 0,
+        inline_delegations => 1,
 
         @args,
     );
 }
 
+sub _install_inlined_code {
+    my ( $self, %args ) = @_;
+
+    $self->SUPER::_install_inlined_code(%args);
+    $self->_inline_delegations(%args) if $args{inline_delegations};
+}
+
+sub _inline_delegations {
+    my $self = shift;
+    foreach my $attr_name ( $self->get_attribute_list ) {
+        my $attr = $self->get_attribute($attr_name);
+        $attr->install_delegation(1) if $attr->can('install_delegation');
+    }
+}
+
 sub create {
     my ($self, $package_name, %options) = @_;
 
diff --git a/lib/Moose/Meta/Method/Delegation.pm b/lib/Moose/Meta/Method/Delegation.pm
index 1729a91..6c13337 100644
--- a/lib/Moose/Meta/Method/Delegation.pm
+++ b/lib/Moose/Meta/Method/Delegation.pm
@@ -12,7 +12,7 @@ $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
 
 use base 'Moose::Meta::Method',
-         'Class::MOP::Method::Generated';
+         'Class::MOP::Method::Inlined';
 
 
 sub new {
@@ -65,6 +65,31 @@ sub associated_attribute { (shift)->{'attribute'} }
 
 sub delegate_to_method { (shift)->{'delegate_to_method'} }
 
+sub is_inline {
+    (shift)->{is_inline}
+}
+
+sub definition_context {
+    exists $_[0]->{definition_context} ? $_[0]->{definition_context}
+        : ($_[0]->{definition_context} = $_[0]->_generate_definition_context);
+}
+
+sub _generate_definition_context {
+    my $self = shift;
+    my $attr = $self->associated_attribute;
+    my $ctx = $attr->definition_context;
+    return unless $ctx;
+
+    my $desc = "delegation of "
+        . $self->name
+        . ' to '
+        . $attr->name
+        . '->'
+        . $self->delegate_to_method;
+
+    return { %$ctx, description => $desc };
+}
+
 sub _initialize_body {
     my $self = shift;
 
@@ -72,6 +97,60 @@ sub _initialize_body {
     return $self->{body} = $method_to_call
         if ref $method_to_call;
 
+    return $self->{body} = $self->is_inline
+        ? $self->_generate_body_inline
+        : $self->_generate_body;
+}
+
+sub _generate_body_inline {
+    my $self = shift;
+    my $method_to_call = $self->delegate_to_method;
+    my $attr = $self->associated_attribute;
+    my $attr_name = $attr->name;
+    my $meta_instance = $attr->associated_class->instance_metaclass;
+    my $handle_name = $self->name;
+
+    my ( $code, $e ) = $self->_compile_code(
+        environment => {
+            '@curried_arguments' => $self->curried_arguments,
+            '$method' => \$self,
+        },
+        code => (
+            'sub {'."\n"
+            . 'my $instance = shift; '."\n"
+            . 'my $proxy = '
+            . $meta_instance->inline_get_slot_value('$instance',$attr_name)
+            . ';'."\n"
+            . 'my $error '."\n"
+            . '  = !defined $proxy                  ?  q{ is not defined} '."\n"
+            . q{  : ref($proxy) && !Scalar::Util::blessed($proxy) ? qq{ is not an object (got '$proxy')} }."\n"
+            . '  : undef;'."\n"
+            . 'if ($error) {'."\n"
+            . '  $method->throw_error('."\n"
+            . '    "Cannot delegate '. $handle_name.' to '.$method_to_call
+            . ' because the value of '
+            . $attr_name
+            . '" . $error, '."\n"
+            . '  method_name => q{'.$method_to_call.'}, '."\n"
+            . '  object      => $instance, '."\n"
+            . ');}'."\n"
+            . ($self->curried_arguments
+                   ? 'unshift @_, @{curried_arguments};'."\n"
+                   : '')
+            . '$proxy->'.$method_to_call.'(@_);'."\n"
+            . '};'
+        ),
+    );
+    confess "Could not generate inline accessor because : $e" if $e;
+
+    return $code;
+}
+
+sub _generate_body {
+    my $self = shift;
+
+    my $method_to_call = $self->delegate_to_method;
+
     my $accessor = $self->_get_delegate_accessor;
 
     my $handle_name = $self->name;
@@ -85,7 +164,7 @@ sub _initialize_body {
     # all... the only thing that would end up different would be
     # interpolating in $method_to_call, and a bunch of things in the
     # error handling that mostly never gets called - doy
-    $self->{body} = sub {
+    return sub {
         my $instance = shift;
         my $proxy    = $instance->$accessor();
 
diff --git a/t/020_attributes/010_attribute_delegation.t b/t/020_attributes/010_attribute_delegation.t
index 16ec30e..a6020ca 100644
--- a/t/020_attributes/010_attribute_delegation.t
+++ b/t/020_attributes/010_attribute_delegation.t
@@ -22,6 +22,8 @@ use Test::Exception;
 
     sub baz { 42 }
 
+    sub quux { confess }
+
     package Bar;
     use Moose;
 
@@ -31,64 +33,86 @@ use Test::Exception;
         handles => {
             'foo_bar' => 'bar',
             foo_baz => 'baz',
+            foo_quux => 'quux',
             'foo_bar_to_20' => [ bar => 20 ],
         },
     );
 }
 
-my $bar = Bar->new;
-isa_ok($bar, 'Bar');
+sub test_hash_handles {
+    my $bar = shift;
+    isa_ok($bar, 'Bar');
 
-ok($bar->foo, '... we have something in bar->foo');
-isa_ok($bar->foo, 'Foo');
+    ok($bar->foo, '... we have something in bar->foo');
+    isa_ok($bar->foo, 'Foo');
 
-my $meth = Bar->meta->get_method('foo_bar');
-isa_ok($meth, 'Moose::Meta::Method::Delegation');
-is($meth->associated_attribute->name, 'foo',
-   'associated_attribute->name for this method is foo');
+    my $meth = Bar->meta->get_method('foo_bar');
+    isa_ok($meth, 'Moose::Meta::Method::Delegation');
+    is($meth->associated_attribute->name, 'foo',
+       'associated_attribute->name for this method is foo');
 
-is($bar->foo->bar, 10, '... bar->foo->bar returned the right default');
+    is($bar->foo->bar, 10, '... bar->foo->bar returned the right default');
 
-can_ok($bar, 'foo_bar');
-is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly');
+    can_ok($bar, 'foo_bar');
+    is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly');
 
-# change the value ...
+    # change the value ...
 
-$bar->foo->bar(30);
+    $bar->foo->bar(30);
 
-# and make sure the delegation picks it up
+    # and make sure the delegation picks it up
 
-is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
-is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
+    is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
+    is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
 
-# change the value through the delegation ...
+    # change the value through the delegation ...
 
-$bar->foo_bar(50);
+    $bar->foo_bar(50);
 
-# and make sure everyone sees it
+    # and make sure everyone sees it
 
-is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
-is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
+    is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
+    is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
 
-# change the object we are delegating too
+    # change the object we are delegating too
 
-my $foo = Foo->new(bar => 25);
-isa_ok($foo, 'Foo');
+    my $foo = Foo->new(bar => 25);
+    isa_ok($foo, 'Foo');
 
-is($foo->bar, 25, '... got the right foo->bar');
+    is($foo->bar, 25, '... got the right foo->bar');
 
-lives_ok {
-    $bar->foo($foo);
-} '... assigned the new Foo to Bar->foo';
+    lives_ok {
+        $bar->foo($foo);
+    } '... assigned the new Foo to Bar->foo';
+
+    is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
+
+    is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
+    is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
 
-is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
+    # curried handles
+    $bar->foo_bar_to_20;
+    is($bar->foo_bar, 20, '... correctly curried a single argument');
+}
+
+# Works with a mutable class
 
-is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
-is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
+{
+    test_hash_handles(Bar->new);
+}
 
-# curried handles
-$bar->foo_bar_to_20;
-is($bar->foo_bar, 20, '... correctly curried a single argument');
+# Works with an immutable class and provides a meaningful backtrace
+
+{
+    Bar->meta->make_immutable;
+    my $filename = __FILE__;
+    my $bar = Bar->new;
+    test_hash_handles($bar);
+    throws_ok { $bar->foo_quux } qr/delegation of foo_quux to foo->quux/,
+        'error location describes the delegation';
+    throws_ok { $bar->foo_quux } qr/defined at $filename line \d+/,
+        '... and points at where the handler is defined';
+}
 
 # -------------------------------------------------------------------
 # ARRAY handles
diff --git a/xt/author/pod_coverage.t b/xt/author/pod_coverage.t
index acfdff6..07a40ba 100644
--- a/xt/author/pod_coverage.t
+++ b/xt/author/pod_coverage.t
@@ -56,6 +56,7 @@ my %trustme = (
             options
             )
     ],
+    'Moose::Meta::Method::Delegation' => [ 'definition_context', 'is_inline' ],
     'Moose::Meta::Method::Destructor' => [ 'initialize_body', 'options' ],
     'Moose::Meta::Role'               => [
         qw( alias_method