Ignore all .git.*
[gitmo/Class-MOP.git] / t / 003_methods.t
1 use strict;
2 use warnings;
3
4 use Test::More tests => 67;
5 use Test::Exception;
6
7 use Scalar::Util qw/reftype/;
8 use Sub::Name;
9
10 use Class::MOP;
11 use Class::MOP::Class;
12 use Class::MOP::Method;
13
14 {   # This package tries to test &has_method 
15     # as exhaustively as possible. More corner
16     # cases are welcome :)
17     package Foo;
18     
19     # import a sub
20     use Scalar::Util 'blessed'; 
21     
22     sub pie;
23     sub cake ();
24
25     use constant FOO_CONSTANT => 'Foo-CONSTANT';
26     
27     # define a sub in package
28     sub bar { 'Foo::bar' } 
29     *baz = \&bar;
30     
31     # create something with the typeglob inside the package
32     *baaz = sub { 'Foo::baaz' };    
33
34     { # method named with Sub::Name inside the package scope
35         no strict 'refs';
36         *{'Foo::floob'} = Sub::Name::subname 'floob' => sub { '!floob!' }; 
37     }
38
39     # We hateses the "used only once" warnings
40     { 
41         my $temp1 = \&Foo::baz;
42         my $temp2 = \&Foo::baaz;    
43     }
44     
45     package OinkyBoinky;
46     our @ISA = "Foo";
47     
48     sub elk { 'OinkyBoinky::elk' }
49
50     package main;
51     
52     sub Foo::blah { $_[0]->Foo::baz() }
53     
54     {
55         no strict 'refs';
56         *{'Foo::bling'} = sub { '$$Bling$$' };
57         *{'Foo::bang'} = Sub::Name::subname 'Foo::bang' => sub { '!BANG!' }; 
58         *{'Foo::boom'} = Sub::Name::subname 'boom' => sub { '!BOOM!' };     
59         
60         eval "package Foo; sub evaled_foo { 'Foo::evaled_foo' }";           
61     }
62 }
63
64 my $Foo = Class::MOP::Class->initialize('Foo');
65
66 ok($Foo->has_method('pie'), '... got the method stub pie');
67 ok($Foo->has_method('cake'), '... got the constant method stub cake');
68
69 my $foo = sub { 'Foo::foo' };
70
71 ok(!UNIVERSAL::isa($foo, 'Class::MOP::Method'), '... our method is not yet blessed');
72
73 lives_ok {
74     $Foo->add_method('foo' => $foo);
75 } '... we added the method successfully';
76
77 my $foo_method = $Foo->get_method('foo');
78
79 isa_ok($foo_method, 'Class::MOP::Method');
80
81 is($foo_method->name, 'foo', '... got the right name for the method');
82 is($foo_method->package_name, 'Foo', '... got the right package name for the method');
83
84 ok($Foo->has_method('foo'), '... Foo->has_method(foo) (defined with Sub::Name)');
85
86 is($Foo->get_method('foo')->body, $foo, '... Foo->get_method(foo) == \&foo');
87 is($Foo->get_method('foo')->execute, 'Foo::foo', '... _method_foo->execute returns "Foo::foo"');
88 is(Foo->foo(), 'Foo::foo', '... Foo->foo() returns "Foo::foo"');
89
90 # now check all our other items ...
91
92 ok($Foo->has_method('FOO_CONSTANT'), '... not Foo->has_method(FOO_CONSTANT) (defined w/ use constant)');
93 ok(!$Foo->has_method('bling'), '... not Foo->has_method(bling) (defined in main:: using symbol tables (no Sub::Name))');
94
95 ok($Foo->has_method('bar'), '... Foo->has_method(bar) (defined in Foo)');
96 ok($Foo->has_method('baz'), '... Foo->has_method(baz) (typeglob aliased within Foo)');
97 ok($Foo->has_method('baaz'), '... Foo->has_method(baaz) (typeglob aliased within Foo)');
98 ok($Foo->has_method('floob'), '... Foo->has_method(floob) (defined in Foo:: using symbol tables and Sub::Name w/out package name)');
99 ok($Foo->has_method('blah'), '... Foo->has_method(blah) (defined in main:: using fully qualified package name)');
100 ok($Foo->has_method('bang'), '... Foo->has_method(bang) (defined in main:: using symbol tables and Sub::Name)');
101 ok($Foo->has_method('evaled_foo'), '... Foo->has_method(evaled_foo) (evaled in main::)');
102
103 my $OinkyBoinky = Class::MOP::Class->initialize('OinkyBoinky');
104
105 ok($OinkyBoinky->has_method('elk'), "the method 'elk' is defined in OinkyBoinky");
106
107 ok(!$OinkyBoinky->has_method('bar'), "the method 'bar' is not defined in OinkyBoinky");
108
109 ok(my $bar = $OinkyBoinky->find_method_by_name('bar'), "but if you look in the inheritence chain then 'bar' does exist");
110
111 is( reftype($bar->body), "CODE", "the returned value is a code ref" );
112
113
114 # calling get_method blessed them all
115 for my $method_name (qw/baaz
116                         bar
117                         baz
118                         floob
119                         blah
120                         bang
121                         evaled_foo
122                         FOO_CONSTANT/) {
123     isa_ok($Foo->get_method($method_name), 'Class::MOP::Method');
124     {
125         no strict 'refs';
126         is($Foo->get_method($method_name)->body, \&{'Foo::' . $method_name}, '... body matches CODE ref in package for ' . $method_name);
127     }
128 }
129
130 for my $method_name (qw/
131                     bling
132                     /) {
133     is(ref($Foo->get_package_symbol('&' . $method_name)), 'CODE', '... got the __ANON__ methods');
134     {
135         no strict 'refs';
136         is($Foo->get_package_symbol('&' . $method_name), \&{'Foo::' . $method_name}, '... symbol matches CODE ref in package for ' . $method_name);
137     }
138 }
139
140 {
141     package Foo::Aliasing;
142     use metaclass;
143     sub alias_me { '...' }
144 }
145
146 $Foo->alias_method('alias_me' => Foo::Aliasing->meta->get_method('alias_me'));
147
148 ok($Foo->has_method('alias_me'), '... Foo->has_method(alias_me) (aliased from Foo::Aliasing)');
149 ok(defined &Foo::alias_me, '... Foo does have a symbol table slow for alias_me though');
150
151 ok(!$Foo->has_method('blessed'), '... !Foo->has_method(blessed) (imported into Foo)');
152 ok(!$Foo->has_method('boom'), '... !Foo->has_method(boom) (defined in main:: using symbol tables and Sub::Name w/out package name)');
153
154 ok(!$Foo->has_method('not_a_real_method'), '... !Foo->has_method(not_a_real_method) (does not exist)');
155 is($Foo->get_method('not_a_real_method'), undef, '... Foo->get_method(not_a_real_method) == undef');
156
157 is_deeply(
158     [ sort $Foo->get_method_list ],
159     [ qw(FOO_CONSTANT alias_me baaz bang bar baz blah cake evaled_foo floob foo pie) ],
160     '... got the right method list for Foo');
161
162 is_deeply(
163     [ sort { $a->name cmp $b->name } $Foo->get_all_methods() ],
164     [
165         map { $Foo->get_method($_) } qw(
166             FOO_CONSTANT
167             alias_me
168             baaz            
169             bang 
170             bar 
171             baz 
172             blah 
173             cake
174             evaled_foo 
175             floob 
176             foo
177             pie
178         )
179     ],
180     '... got the right list of applicable methods for Foo');
181
182 is($Foo->remove_method('foo')->body, $foo, '... removed the foo method');
183 ok(!$Foo->has_method('foo'), '... !Foo->has_method(foo) we just removed it');
184 ok(!$Foo->get_method_map->{foo}, 'foo is not in the method map');
185 dies_ok { Foo->foo } '... cannot call Foo->foo because it is not there';
186
187 is_deeply(
188     [ sort $Foo->get_method_list ],
189     [ qw(FOO_CONSTANT alias_me baaz bang bar baz blah cake evaled_foo floob pie) ],
190     '... got the right method list for Foo');
191
192
193 # ... test our class creator 
194
195 my $Bar = Class::MOP::Class->create(
196     package      => 'Bar',
197     superclasses => [ 'Foo' ],
198     methods      => {
199         foo => sub { 'Bar::foo' },
200         bar => sub { 'Bar::bar' },                    
201     }
202 );
203 isa_ok($Bar, 'Class::MOP::Class');
204
205 ok($Bar->has_method('foo'), '... Bar->has_method(foo)');
206 ok($Bar->has_method('bar'), '... Bar->has_method(bar)');
207
208 is(Bar->foo, 'Bar::foo', '... Bar->foo == Bar::foo');
209 is(Bar->bar, 'Bar::bar', '... Bar->bar == Bar::bar');
210
211 lives_ok {
212     $Bar->add_method('foo' => sub { 'Bar::foo v2' });
213 } '... overwriting a method is fine';
214
215 ok($Bar->has_method('foo'), '... Bar-> (still) has_method(foo)');
216 is(Bar->foo, 'Bar::foo v2', '... Bar->foo == "Bar::foo v2"');
217
218 is_deeply(
219     [ sort $Bar->get_method_list ],
220     [ qw(bar foo meta) ],
221     '... got the right method list for Bar');  
222     
223 is_deeply(
224     [ sort { $a->name cmp $b->name } $Bar->get_all_methods() ],
225     [
226         $Foo->get_method('FOO_CONSTANT'),
227         $Foo->get_method('alias_me'),
228         $Foo->get_method('baaz'),
229         $Foo->get_method('bang'),
230         $Bar->get_method('bar'),
231         (map { $Foo->get_method($_) } qw(        
232             baz 
233             blah 
234             cake
235             evaled_foo 
236             floob 
237         )),
238         $Bar->get_method('foo'),
239         $Bar->get_method('meta'),
240         $Foo->get_method('pie'),
241     ],
242     '... got the right list of applicable methods for Bar');
243
244 my $method = Class::MOP::Method->wrap(
245     name         => 'objecty',
246     package_name => 'Whatever',
247     body         => sub {q{I am an object, and I feel an object's pain}},
248 );
249
250 Bar->meta->add_method( $method->name, $method );
251
252 my $new_method = Bar->meta->get_method('objecty');
253
254 isnt( $method, $new_method, 'add_method clones method objects as they are added' );
255 is( $new_method->original_method, $method, '... the cloned method has the correct original method' );