From: Jesse Luehrs <doy@tozt.net>
Date: Sun, 24 Apr 2011 16:12:25 +0000 (-0500)
Subject: add definition_context info for inlined constructors and destructors
X-Git-Tag: 2.0100~196
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0f1a71fc19c13d0a223fab58d7807fb4d45beab7;p=gitmo%2FMoose.git

add definition_context info for inlined constructors and destructors
---

diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm
index 808cb0f..d16d66f 100644
--- a/lib/Class/MOP/Attribute.pm
+++ b/lib/Class/MOP/Attribute.pm
@@ -378,7 +378,7 @@ sub _process_accessors {
         my $method;
         try {
             if ( $method_ctx ) {
-                my $desc = "accessor $accessor";
+                my $desc = "accessor " . $self->associated_class->name . "::$accessor";
                 if ( $accessor ne $self->name ) {
                     $desc .= " of attribute " . $self->name;
                 }
diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 8aa4170..9fc62b3 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -1256,8 +1256,13 @@ sub _immutable_options {
 sub make_immutable {
     my ( $self, @args ) = @_;
 
+    my ($file, $line) = (caller)[1..2];
     if ( $self->is_mutable ) {
-        $self->_initialize_immutable( $self->_immutable_options(@args) );
+        $self->_initialize_immutable(
+            $self->_immutable_options(@args),
+            file => $file,
+            line => $line,
+        );
         $self->_rebless_as_immutable(@args);
         return $self;
     }
@@ -1413,6 +1418,11 @@ sub _inline_constructor {
         is_inline    => 1,
         package_name => $self->name,
         name         => $name,
+        definition_context => {
+            description => "constructor " . $self->name . "::" . $name,
+            file        => $args{file},
+            line        => $args{line},
+        },
     );
 
     if ( $args{replace_constructor} or $constructor->can_be_inlined ) {
@@ -1445,7 +1455,12 @@ sub _inline_destructor {
         options      => \%args,
         metaclass    => $self,
         package_name => $self->name,
-        name         => 'DESTROY'
+        name         => 'DESTROY',
+        definition_context => {
+            description => "destructor " . $self->name . "::DESTROY",
+            file        => $args{file},
+            line        => $args{line},
+        },
     );
 
     if ( $args{replace_destructor} or $destructor->can_be_inlined ) {
diff --git a/lib/Moose/Meta/Method/Constructor.pm b/lib/Moose/Meta/Method/Constructor.pm
index bc20c51..695b826 100644
--- a/lib/Moose/Meta/Method/Constructor.pm
+++ b/lib/Moose/Meta/Method/Constructor.pm
@@ -29,6 +29,7 @@ sub new {
         'name'          => $options{name},
         'options'       => $options{options},
         'associated_metaclass' => $meta,
+        'definition_context' => $options{definition_context},
         '_expected_method_class' => $options{_expected_method_class} || 'Moose::Object',
     } => $class;
 
diff --git a/lib/Moose/Meta/Method/Destructor.pm b/lib/Moose/Meta/Method/Destructor.pm
index 2ce956d..1c3ceca 100644
--- a/lib/Moose/Meta/Method/Destructor.pm
+++ b/lib/Moose/Meta/Method/Destructor.pm
@@ -28,6 +28,7 @@ sub new {
         'name'                 => $options{name},
         # ...
         'options'              => $options{options},
+        'definition_context'   => $options{definition_context},
         'associated_metaclass' => $options{metaclass},
     } => $class;
 
diff --git a/t/immutable/definition_context.t b/t/immutable/definition_context.t
new file mode 100644
index 0000000..de82c88
--- /dev/null
+++ b/t/immutable/definition_context.t
@@ -0,0 +1,83 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Test::Fatal;
+
+{
+    use Moose::Util::TypeConstraints;
+    use Carp 'confess';
+    subtype 'Death', as 'Int', where { $_ == 1 };
+    coerce  'Death', from 'Any', via { confess };
+}
+
+{
+    my ($attr_foo_line, $attr_bar_line, $ctor_line);
+    {
+        package Foo;
+        use Moose;
+
+        has foo => (
+            is     => 'rw',
+            isa    => 'Death',
+            coerce => 1,
+        );
+        $attr_foo_line = __LINE__ - 5;
+
+        has bar => (
+            accessor => 'baz',
+            isa      => 'Death',
+            coerce   => 1,
+        );
+        $attr_bar_line = __LINE__ - 5;
+
+        __PACKAGE__->meta->make_immutable;
+        $ctor_line = __LINE__ - 1;
+    }
+
+    like(
+        exception { Foo->new(foo => 2) },
+        qr/called at constructor Foo::new \(defined at $0 line $ctor_line\)/,
+        "got definition context for the constructor"
+    );
+
+    like(
+        exception { my $f = Foo->new(foo => 1); $f->foo(2) },
+        qr/called at accessor Foo::foo \(defined at $0 line $attr_foo_line\)/,
+        "got definition context for the accessor"
+    );
+
+    like(
+        exception { my $f = Foo->new(foo => 1); $f->baz(2) },
+        qr/called at accessor Foo::baz of attribute bar \(defined at $0 line $attr_bar_line\)/,
+        "got definition context for the accessor"
+    );
+}
+
+{
+    my ($dtor_line);
+    {
+        package Bar;
+        use Moose;
+
+        # just dying here won't work, because perl's exception handling is
+        # terrible
+        sub DEMOLISH { try { confess } catch { warn $_ } }
+
+        __PACKAGE__->meta->make_immutable;
+        $dtor_line = __LINE__ - 1;
+    }
+
+    {
+        my $warning = '';
+        local $SIG{__WARN__} = sub { $warning .= $_[0] };
+        { Bar->new }
+        like(
+            $warning,
+            qr/called at destructor Bar::DESTROY \(defined at $0 line $dtor_line\)/,
+            "got definition context for the destructor"
+        );
+    }
+}
+
+done_testing;