Commit | Line | Data |
38bf2a25 |
1 | use strict; |
2 | use warnings; |
3 | |
4 | use Test::More; |
5 | use Test::Fatal; |
6 | |
7 | use Class::MOP; |
8 | use Class::MOP::Method; |
9 | |
10 | my $method = Class::MOP::Method->wrap( |
11 | sub {1}, |
12 | package_name => 'main', |
13 | name => '__ANON__', |
14 | ); |
15 | is( $method->meta, Class::MOP::Method->meta, |
16 | '... instance and class both lead to the same meta' ); |
17 | |
18 | is( $method->package_name, 'main', '... our package is main::' ); |
19 | is( $method->name, '__ANON__', '... our sub name is __ANON__' ); |
20 | is( $method->fully_qualified_name, 'main::__ANON__', |
21 | '... our subs full name is main::__ANON__' ); |
22 | is( $method->original_method, undef, '... no original_method ' ); |
23 | is( $method->original_package_name, 'main', |
24 | '... the original_package_name is the same as package_name' ); |
25 | is( $method->original_name, '__ANON__', |
26 | '... the original_name is the same as name' ); |
27 | is( $method->original_fully_qualified_name, 'main::__ANON__', |
28 | '... the original_fully_qualified_name is the same as fully_qualified_name' |
29 | ); |
30 | |
31 | isnt( exception { Class::MOP::Method->wrap }, undef, q{... can't call wrap() without some code} ); |
32 | isnt( exception { Class::MOP::Method->wrap( [] ) }, undef, q{... can't call wrap() without some code} ); |
33 | isnt( exception { Class::MOP::Method->wrap( bless {} => 'Fail' ) }, undef, q{... can't call wrap() without some code} ); |
34 | |
35 | isnt( exception { Class::MOP::Method->name }, undef, q{... can't call name() as a class method} ); |
36 | isnt( exception { Class::MOP::Method->body }, undef, q{... can't call body() as a class method} ); |
37 | isnt( exception { Class::MOP::Method->package_name }, undef, q{... can't call package_name() as a class method} ); |
38 | isnt( exception { Class::MOP::Method->fully_qualified_name }, undef, q{... can't call fully_qualified_name() as a class method} ); |
39 | |
40 | my $meta = Class::MOP::Method->meta; |
41 | isa_ok( $meta, 'Class::MOP::Class' ); |
42 | |
43 | foreach my $method_name ( |
44 | qw( |
45 | wrap |
46 | package_name |
47 | name |
48 | ) |
49 | ) { |
50 | ok( $meta->has_method($method_name), |
51 | '... Class::MOP::Method->has_method(' . $method_name . ')' ); |
52 | my $method = $meta->get_method($method_name); |
53 | is( $method->package_name, 'Class::MOP::Method', |
54 | '... our package is Class::MOP::Method' ); |
55 | is( $method->name, $method_name, |
56 | '... our sub name is "' . $method_name . '"' ); |
57 | } |
58 | |
59 | isnt( exception { |
60 | Class::MOP::Method->wrap(); |
61 | }, undef, '... bad args for &wrap' ); |
62 | |
63 | isnt( exception { |
64 | Class::MOP::Method->wrap('Fail'); |
65 | }, undef, '... bad args for &wrap' ); |
66 | |
67 | isnt( exception { |
68 | Class::MOP::Method->wrap( [] ); |
69 | }, undef, '... bad args for &wrap' ); |
70 | |
71 | isnt( exception { |
72 | Class::MOP::Method->wrap( sub {'FAIL'} ); |
73 | }, undef, '... bad args for &wrap' ); |
74 | |
75 | isnt( exception { |
76 | Class::MOP::Method->wrap( sub {'FAIL'}, package_name => 'main' ); |
77 | }, undef, '... bad args for &wrap' ); |
78 | |
79 | isnt( exception { |
80 | Class::MOP::Method->wrap( sub {'FAIL'}, name => '__ANON__' ); |
81 | }, undef, '... bad args for &wrap' ); |
82 | |
83 | is( exception { |
84 | Class::MOP::Method->wrap( bless( sub {'FAIL'}, "Foo" ), |
85 | name => '__ANON__', package_name => 'Foo::Bar' ); |
86 | }, undef, '... blessed coderef to &wrap' ); |
87 | |
88 | my $clone = $method->clone( |
89 | package_name => 'NewPackage', |
90 | name => 'new_name', |
91 | ); |
92 | |
93 | isa_ok( $clone, 'Class::MOP::Method' ); |
94 | is( $clone->package_name, 'NewPackage', |
95 | '... cloned method has new package name' ); |
96 | is( $clone->name, 'new_name', '... cloned method has new sub name' ); |
97 | is( $clone->fully_qualified_name, 'NewPackage::new_name', |
98 | '... cloned method has new fq name' ); |
99 | is( $clone->original_method, $method, |
100 | '... cloned method has correct original_method' ); |
101 | is( $clone->original_package_name, 'main', |
102 | '... cloned method has correct original_package_name' ); |
103 | is( $clone->original_name, '__ANON__', |
104 | '... cloned method has correct original_name' ); |
105 | is( $clone->original_fully_qualified_name, 'main::__ANON__', |
106 | '... cloned method has correct original_fully_qualified_name' ); |
107 | |
108 | my $clone2 = $clone->clone( |
109 | package_name => 'NewerPackage', |
110 | name => 'newer_name', |
111 | ); |
112 | |
113 | is( $clone2->package_name, 'NewerPackage', |
114 | '... clone of clone has new package name' ); |
115 | is( $clone2->name, 'newer_name', '... clone of clone has new sub name' ); |
116 | is( $clone2->fully_qualified_name, 'NewerPackage::newer_name', |
117 | '... clone of clone new fq name' ); |
118 | is( $clone2->original_method, $clone, |
119 | '... cloned method has correct original_method' ); |
120 | is( $clone2->original_package_name, 'main', |
121 | '... original_package_name follows clone chain' ); |
122 | is( $clone2->original_name, '__ANON__', |
123 | '... original_name follows clone chain' ); |
124 | is( $clone2->original_fully_qualified_name, 'main::__ANON__', |
125 | '... original_fully_qualified_name follows clone chain' ); |
126 | |
127 | Class::MOP::Class->create( |
128 | 'Method::Subclass', |
129 | superclasses => ['Class::MOP::Method'], |
130 | attributes => [ |
131 | Class::MOP::Attribute->new( |
132 | foo => ( |
133 | accessor => 'foo', |
134 | ) |
135 | ), |
136 | ], |
137 | ); |
138 | |
139 | my $wrapped = Method::Subclass->wrap($method, foo => 'bar'); |
140 | isa_ok($wrapped, 'Method::Subclass'); |
141 | isa_ok($wrapped, 'Class::MOP::Method'); |
142 | is($wrapped->foo, 'bar', 'attribute set properly'); |
143 | is($wrapped->package_name, 'main', 'package_name copied properly'); |
144 | is($wrapped->name, '__ANON__', 'method name copied properly'); |
145 | |
146 | my $wrapped2 = Method::Subclass->wrap($method, foo => 'baz', name => 'FOO'); |
147 | is($wrapped2->name, 'FOO', 'got a new method name'); |
148 | |
149 | done_testing; |