From: Jesse Luehrs <doy@tozt.net>
Date: Wed, 15 Jun 2011 22:48:45 +0000 (-0500)
Subject: better definition context for native delegation methods
X-Git-Tag: 2.0102~19
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4e2f0ea7e2b3f484a307af9413c92900f3d66a1a;p=gitmo%2FMoose.git

better definition context for native delegation methods
---

diff --git a/lib/Class/MOP/Method/Generated.pm b/lib/Class/MOP/Method/Generated.pm
index 798720e..f8528bb 100644
--- a/lib/Class/MOP/Method/Generated.pm
+++ b/lib/Class/MOP/Method/Generated.pm
@@ -23,15 +23,25 @@ sub _generate_description {
     my ( $self, $context ) = @_;
     $context ||= $self->definition_context;
 
-    return "generated method (unknown origin)"
-        unless defined $context;
-
-    if (defined $context->{description}) {
-        return "$context->{description} "
-             . "(defined at $context->{file} line $context->{line})";
-    } else {
-        return "$context->{file} (line $context->{line})";
+    my $desc = "generated method";
+    my $origin = "unknown origin";
+
+    if (defined $context) {
+        if (defined $context->{description}) {
+            $desc = $context->{description};
+        }
+
+        if (defined $context->{file} || defined $context->{line}) {
+            $origin = "defined at "
+                    . (defined $context->{file}
+                        ? $context->{file} : "<unknown file>")
+                    . " line "
+                    . (defined $context->{line}
+                        ? $context->{line} : "<unknown line>");
+        }
     }
+
+    return "$desc ($origin)";
 }
 
 sub _compile_code {
diff --git a/lib/Moose/Meta/Method/Accessor/Native.pm b/lib/Moose/Meta/Method/Accessor/Native.pm
index 3fde0c7..f1ff204 100644
--- a/lib/Moose/Meta/Method/Accessor/Native.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native.pm
@@ -20,7 +20,16 @@ around new => sub {
         unless $options{curried_arguments}
             && ref($options{curried_arguments}) eq 'ARRAY';
 
-    $options{definition_context} = $options{attribute}->definition_context;
+    my $attr_context = $options{attribute}->definition_context;
+    my $desc = 'native delegation method ';
+    $desc   .= $options{attribute}->associated_class->name;
+    $desc   .= '::' . $options{name};
+    $desc   .= " ($options{delegate_to_method})";
+    $desc   .= " of attribute " . $options{attribute}->name;
+    $options{definition_context} = {
+        %{ $attr_context || {} },
+        description => $desc,
+    };
 
     $options{accessor_type} = 'native';