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 | ); |
213c00cc |
30 | ok( !$method->is_stub, |
31 | '... the method is not a stub' ); |
38bf2a25 |
32 | |
33 | isnt( exception { Class::MOP::Method->wrap }, undef, q{... can't call wrap() without some code} ); |
34 | isnt( exception { Class::MOP::Method->wrap( [] ) }, undef, q{... can't call wrap() without some code} ); |
35 | isnt( exception { Class::MOP::Method->wrap( bless {} => 'Fail' ) }, undef, q{... can't call wrap() without some code} ); |
36 | |
37 | isnt( exception { Class::MOP::Method->name }, undef, q{... can't call name() as a class method} ); |
38 | isnt( exception { Class::MOP::Method->body }, undef, q{... can't call body() as a class method} ); |
39 | isnt( exception { Class::MOP::Method->package_name }, undef, q{... can't call package_name() as a class method} ); |
40 | isnt( exception { Class::MOP::Method->fully_qualified_name }, undef, q{... can't call fully_qualified_name() as a class method} ); |
41 | |
42 | my $meta = Class::MOP::Method->meta; |
43 | isa_ok( $meta, 'Class::MOP::Class' ); |
44 | |
45 | foreach my $method_name ( |
46 | qw( |
47 | wrap |
48 | package_name |
49 | name |
50 | ) |
51 | ) { |
52 | ok( $meta->has_method($method_name), |
53 | '... Class::MOP::Method->has_method(' . $method_name . ')' ); |
54 | my $method = $meta->get_method($method_name); |
55 | is( $method->package_name, 'Class::MOP::Method', |
56 | '... our package is Class::MOP::Method' ); |
57 | is( $method->name, $method_name, |
58 | '... our sub name is "' . $method_name . '"' ); |
59 | } |
60 | |
61 | isnt( exception { |
62 | Class::MOP::Method->wrap(); |
63 | }, undef, '... bad args for &wrap' ); |
64 | |
65 | isnt( exception { |
66 | Class::MOP::Method->wrap('Fail'); |
67 | }, undef, '... bad args for &wrap' ); |
68 | |
69 | isnt( exception { |
70 | Class::MOP::Method->wrap( [] ); |
71 | }, undef, '... bad args for &wrap' ); |
72 | |
73 | isnt( exception { |
74 | Class::MOP::Method->wrap( sub {'FAIL'} ); |
75 | }, undef, '... bad args for &wrap' ); |
76 | |
77 | isnt( exception { |
78 | Class::MOP::Method->wrap( sub {'FAIL'}, package_name => 'main' ); |
79 | }, undef, '... bad args for &wrap' ); |
80 | |
81 | isnt( exception { |
82 | Class::MOP::Method->wrap( sub {'FAIL'}, name => '__ANON__' ); |
83 | }, undef, '... bad args for &wrap' ); |
84 | |
85 | is( exception { |
86 | Class::MOP::Method->wrap( bless( sub {'FAIL'}, "Foo" ), |
87 | name => '__ANON__', package_name => 'Foo::Bar' ); |
88 | }, undef, '... blessed coderef to &wrap' ); |
89 | |
90 | my $clone = $method->clone( |
91 | package_name => 'NewPackage', |
92 | name => 'new_name', |
93 | ); |
94 | |
95 | isa_ok( $clone, 'Class::MOP::Method' ); |
96 | is( $clone->package_name, 'NewPackage', |
97 | '... cloned method has new package name' ); |
98 | is( $clone->name, 'new_name', '... cloned method has new sub name' ); |
99 | is( $clone->fully_qualified_name, 'NewPackage::new_name', |
100 | '... cloned method has new fq name' ); |
101 | is( $clone->original_method, $method, |
102 | '... cloned method has correct original_method' ); |
103 | is( $clone->original_package_name, 'main', |
104 | '... cloned method has correct original_package_name' ); |
105 | is( $clone->original_name, '__ANON__', |
106 | '... cloned method has correct original_name' ); |
107 | is( $clone->original_fully_qualified_name, 'main::__ANON__', |
108 | '... cloned method has correct original_fully_qualified_name' ); |
109 | |
110 | my $clone2 = $clone->clone( |
111 | package_name => 'NewerPackage', |
112 | name => 'newer_name', |
113 | ); |
114 | |
115 | is( $clone2->package_name, 'NewerPackage', |
116 | '... clone of clone has new package name' ); |
117 | is( $clone2->name, 'newer_name', '... clone of clone has new sub name' ); |
118 | is( $clone2->fully_qualified_name, 'NewerPackage::newer_name', |
119 | '... clone of clone new fq name' ); |
120 | is( $clone2->original_method, $clone, |
121 | '... cloned method has correct original_method' ); |
122 | is( $clone2->original_package_name, 'main', |
123 | '... original_package_name follows clone chain' ); |
124 | is( $clone2->original_name, '__ANON__', |
125 | '... original_name follows clone chain' ); |
126 | is( $clone2->original_fully_qualified_name, 'main::__ANON__', |
127 | '... original_fully_qualified_name follows clone chain' ); |
128 | |
129 | Class::MOP::Class->create( |
130 | 'Method::Subclass', |
131 | superclasses => ['Class::MOP::Method'], |
132 | attributes => [ |
133 | Class::MOP::Attribute->new( |
134 | foo => ( |
135 | accessor => 'foo', |
136 | ) |
137 | ), |
138 | ], |
139 | ); |
140 | |
141 | my $wrapped = Method::Subclass->wrap($method, foo => 'bar'); |
142 | isa_ok($wrapped, 'Method::Subclass'); |
143 | isa_ok($wrapped, 'Class::MOP::Method'); |
144 | is($wrapped->foo, 'bar', 'attribute set properly'); |
145 | is($wrapped->package_name, 'main', 'package_name copied properly'); |
146 | is($wrapped->name, '__ANON__', 'method name copied properly'); |
147 | |
148 | my $wrapped2 = Method::Subclass->wrap($method, foo => 'baz', name => 'FOO'); |
149 | is($wrapped2->name, 'FOO', 'got a new method name'); |
150 | |
213c00cc |
151 | { |
152 | package Foo; |
153 | |
154 | sub full {1} |
155 | sub stub; |
156 | } |
157 | |
158 | { |
159 | my $meta = Class::MOP::Class->initialize('Foo'); |
160 | |
161 | ok( $meta->has_method($_), "Foo class has $_ method" ) |
162 | for qw( full stub ); |
163 | |
164 | my $full = $meta->get_method('full'); |
165 | ok( !$full->is_stub, 'full is not a stub' ); |
166 | |
167 | my $stub = $meta->get_method('stub'); |
168 | |
169 | ok( $stub->is_stub, 'stub is a stub' ); |
170 | } |
171 | |
38bf2a25 |
172 | done_testing; |