Commit | Line | Data |
4c98ebb0 |
1 | use strict; |
2 | use warnings; |
3 | use Test::More tests => 10; |
4 | |
5 | { |
6 | package Ball; |
7 | use Mouse; |
8 | } |
9 | |
10 | { |
11 | package Arbitrary::Roll; |
12 | use Mouse::Role; |
13 | } |
14 | |
15 | my $method_meta = Mouse::Meta::Class->create_anon_class( |
16 | superclasses => ['Mouse::Meta::Method'], |
17 | roles => ['Arbitrary::Roll'], |
18 | ); |
19 | |
20 | # For comparing identity without actually keeping $original_meta around |
21 | my $original_meta = "$method_meta"; |
22 | |
23 | my $method_class = $method_meta->name; |
24 | |
25 | my $method_object = $method_class->wrap( |
26 | sub {'ok'}, |
27 | associated_metaclass => Ball->meta, |
28 | package_name => 'Ball', |
29 | name => 'bounce', |
30 | ); |
31 | |
32 | Ball->meta->add_method( bounce => $method_object ); |
33 | |
34 | for ( 1, 2 ) { |
35 | is( Ball->bounce, 'ok', "method still exists on Ball" ); |
36 | is( Ball->meta->get_method('bounce')->meta->name, $method_class, |
37 | "method's package still exists" ); |
38 | |
39 | is( Ball->meta->get_method('bounce'), $method_object, |
40 | 'original method object is preserved' ); |
41 | |
42 | is( Ball->meta->get_method('bounce')->meta . '', $original_meta, |
43 | "method's metaclass still exists" ); |
44 | ok( Ball->meta->get_method('bounce')->meta->does_role('Arbitrary::Roll'), |
45 | "method still does Arbitrary::Roll" ); |
46 | |
47 | undef $method_meta; |
48 | } |