Add test for new subname behavior

diff --git a/t/003_methods.t b/t/003_methods.t
index e518c36..2b8b6a8 100644 (file)
--- a/t/003_methods.t
+++ b/t/003_methods.t
@@ -200,6 +200,8 @@ lives_ok {
     $Bar->add_method('foo' => sub { 'Bar::foo v2' });
 } '... overwriting a method is fine';
 
+is_deeply( [ Class::MOP::get_code_info($Bar->get_method('foo')->body) ], [ "Bar", "foo" ], "subname applied to anonymous method" );
+
 ok($Bar->has_method('foo'), '... Bar-> (still) has_method(foo)');
 is(Bar->foo, 'Bar::foo v2', '... Bar->foo == "Bar::foo v2"');
 

diff --git a/t/309_subname.t b/t/309_subname.t
new file mode 100644 (file)
index 0000000..ea1fc53
--- /dev/null
+++ b/t/309_subname.t
@@ -0,0 +1,40 @@
+use strict;
+use warnings;
+
+use Test::More tests => 6;
+
+use Class::MOP;
+
+{
+
+    package Origin;
+    sub bar { ( caller(0) )[3] }
+
+    package Foo;
+}
+
+my $Foo = Class::MOP::Class->initialize('Foo');
+
+$Foo->add_method( foo => sub { ( caller(0) )[3] } );
+
+is_deeply(
+    [ Class::MOP::get_code_info( $Foo->get_method('foo')->body ) ],
+    [ "Foo", "foo" ],
+    "subname applied to anonymous method",
+);
+
+is( Foo->foo, "Foo::foo", "caller() aggrees" );
+
+$Foo->add_method( bar => \&Origin::bar );
+
+is( Origin->bar, "Origin::bar", "normal caller() operation in unrelated class" );
+
+is_deeply(
+    [ Class::MOP::get_code_info( $Foo->get_method('foo')->body ) ],
+    [ "Foo", "foo" ],
+    "subname not applied if a name already exists",
+);
+
+is( Foo->bar, "Origin::bar", "caller aggrees" );
+
+is( Origin->bar, "Origin::bar", "unrelated class untouched" );