this is broken, we need to fix it
[gitmo/Moose.git] / lib / Moose / Role.pm
1
2 package Moose::Role;
3
4 use strict;
5 use warnings;
6
7 use Scalar::Util 'blessed';
8 use Carp         'confess';
9 use Sub::Name    'subname';
10
11 use Sub::Exporter;
12
13 our $VERSION = '0.05';
14
15 use Moose ();
16
17 use Moose::Meta::Role;
18 use Moose::Util::TypeConstraints;
19
20 {
21     my ( $CALLER, %METAS );
22
23     sub _find_meta {
24         my $role = $CALLER;
25
26         return $METAS{$role} if exists $METAS{$role};
27         
28         # make a subtype for each Moose class
29         subtype $role
30             => as 'Role'
31             => where { $_->does($role) }
32         unless find_type_constraint($role);        
33
34         my $meta;
35         if ($role->can('meta')) {
36                 $meta = $role->meta();
37                 (blessed($meta) && $meta->isa('Moose::Meta::Role'))
38                 || confess "You already have a &meta function, but it does not return a Moose::Meta::Role";
39         }
40         else {
41                 $meta = Moose::Meta::Role->initialize($role);
42                 $meta->Moose::Meta::Class::add_method('meta' => sub { $meta })          
43         }
44
45         return $METAS{$role} = $meta;
46     }
47  
48         
49     my %exports = (   
50         extends => sub {
51             my $meta = _find_meta();
52             return subname 'Moose::Role::extends' => sub { 
53                 confess "Moose::Role does not currently support 'extends'"
54                 };
55             },
56             with => sub {
57                 my $meta = _find_meta();
58                 return subname 'Moose::Role::with' => sub (@) { 
59                 my (@roles) = @_;
60                 confess "Must specify at least one role" unless @roles;
61                 Moose::_load_all_classes(@roles);
62                 ($_->can('meta') && $_->meta->isa('Moose::Meta::Role'))
63                     || confess "You can only consume roles, $_ is not a Moose role"
64                         foreach @roles;
65                 if (scalar @roles == 1) {
66                     $roles[0]->meta->apply($meta);
67                 }
68                 else {
69                     Moose::Meta::Role->combine(
70                         map { $_->meta } @roles
71                     )->apply($meta);
72                 }
73             };
74             },  
75         requires => sub {
76             my $meta = _find_meta();
77             return subname 'Moose::Role::requires' => sub (@) { 
78                 confess "Must specify at least one method" unless @_;
79                 $meta->add_required_methods(@_);
80                 };
81             },  
82         excludes => sub {
83             my $meta = _find_meta();
84             return subname 'Moose::Role::excludes' => sub (@) { 
85                 confess "Must specify at least one role" unless @_;
86                 $meta->add_excluded_roles(@_);
87                 };
88             },      
89         has => sub {
90             my $meta = _find_meta();
91             return subname 'Moose::Role::has' => sub ($;%) { 
92                         my ($name, %options) = @_;
93                         $meta->add_attribute($name, %options) 
94                 };
95             },
96         before => sub {
97             my $meta = _find_meta();
98             return subname 'Moose::Role::before' => sub (@&) { 
99                 my $code = pop @_;
100                 $meta->add_before_method_modifier($_, $code) for @_;
101                 };
102             },
103         after => sub {
104             my $meta = _find_meta();
105             return subname 'Moose::Role::after' => sub (@&) { 
106                         my $code = pop @_;
107                         $meta->add_after_method_modifier($_, $code) for @_;
108                 };
109             },
110         around => sub {
111             my $meta = _find_meta();
112             return subname 'Moose::Role::around' => sub (@&) { 
113                         my $code = pop @_;
114                         $meta->add_around_method_modifier($_, $code) for @_;
115                 };
116             },
117             super => sub {
118             my $meta = _find_meta();
119             return subname 'Moose::Role::super' => sub {};
120         },
121         override => sub {
122             my $meta = _find_meta();
123             return subname 'Moose::Role::override' => sub ($&) {
124                 my ($name, $code) = @_;
125                 $meta->add_override_method_modifier($name, $code);
126                 };
127             },          
128         inner => sub {
129             my $meta = _find_meta();
130             return subname 'Moose::Role::inner' => sub {
131                 confess "Moose::Role cannot support 'inner'";
132                 };
133             },
134         augment => sub {
135             my $meta = _find_meta();
136             return subname 'Moose::Role::augment' => sub {
137                 confess "Moose::Role cannot support 'augment'";
138                 };
139             },
140         confess => sub {
141             return \&Carp::confess;
142         },
143         blessed => sub {
144             return \&Scalar::Util::blessed;
145         }           
146         );      
147
148     my $exporter = Sub::Exporter::build_exporter({ 
149         exports => \%exports,
150         groups  => {
151             default => [':all']
152         }
153     });
154     
155     sub import {
156         $CALLER = caller();
157         
158         strict->import;
159         warnings->import;        
160
161         # we should never export to main
162         return if $CALLER eq 'main';
163
164         goto $exporter;
165     };
166
167 }
168
169 1;
170
171 __END__
172
173 =pod
174
175 =head1 NAME
176
177 Moose::Role - The Moose Role
178
179 =head1 SYNOPSIS
180
181   package Eq;
182   use strict;
183   use warnings;
184   use Moose::Role;
185   
186   requires 'equal';
187   
188   sub no_equal { 
189       my ($self, $other) = @_;
190       !$self->equal($other);
191   }
192   
193   # ... then in your classes
194   
195   package Currency;
196   use strict;
197   use warnings;
198   use Moose;
199   
200   with 'Eq';
201   
202   sub equal {
203       my ($self, $other) = @_;
204       $self->as_float == $other->as_float;
205   }
206
207 =head1 DESCRIPTION
208
209 Role support in Moose is coming along quite well. It's best documentation 
210 is still the the test suite, but it is fairly safe to assume Perl 6 style 
211 behavior, and then either refer to the test suite, or ask questions on 
212 #moose if something doesn't quite do what you expect. More complete 
213 documentation is planned and will be included with the next official 
214 (non-developer) release.
215
216 =head1 EXPORTED FUNCTIONS
217
218 Currently Moose::Role supports all of the functions that L<Moose> exports, 
219 but differs slightly in how some items are handled (see L<CAVEATS> below 
220 for details). 
221
222 Moose::Role also offers two role specific keyword exports:
223
224 =over 4
225
226 =item B<requires (@method_names)>
227
228 Roles can require that certain methods are implemented by any class which 
229 C<does> the role. 
230
231 =item B<excludes (@role_names)>
232
233 Roles can C<exclude> other roles, in effect saying "I can never be combined
234 with these C<@role_names>". This is a feature which should not be used 
235 lightly. 
236
237 =back
238
239 =head1 CAVEATS
240
241 The role support now has only a few caveats. They are as follows:
242
243 =over 4
244
245 =item *
246
247 Roles cannot use the C<extends> keyword, it will throw an exception for now. 
248 The same is true of the C<augment> and C<inner> keywords (not sure those 
249 really make sense for roles). All other Moose keywords will be I<deferred> 
250 so that they can be applied to the consuming class. 
251
252 =item * 
253
254 Role composition does it's best to B<not> be order sensitive when it comes
255 to conflict resolution and requirements detection. However, it is order 
256 sensitive when it comes to method modifiers. All before/around/after modifiers
257 are included whenever a role is composed into a class, and then are applied 
258 in the order the roles are used. This too means that there is no conflict for 
259 before/around/after modifiers as well. 
260
261 In most cases, this will be a non issue, however it is something to keep in 
262 mind when using method modifiers in a role. You should never assume any 
263 ordering.
264
265 =item *
266
267 The C<requires> keyword currently only works with actual methods. A method 
268 modifier (before/around/after and override) will not count as a fufillment 
269 of the requirement, and neither will an autogenerated accessor for an attribute.
270
271 It is likely that the attribute accessors will eventually be allowed to fufill 
272 those requirements, either that or we will introduce a C<requires_attr> keyword
273 of some kind instead. This descision has not yet been finalized.
274
275 =back
276
277 =head1 BUGS
278
279 All complex software has bugs lurking in it, and this module is no 
280 exception. If you find a bug please either email me, or add the bug
281 to cpan-RT.
282
283 =head1 AUTHOR
284
285 Stevan Little E<lt>stevan@iinteractive.comE<gt>
286
287 Christian Hansen E<lt>chansen@cpan.orgE<gt>
288
289 =head1 COPYRIGHT AND LICENSE
290
291 Copyright 2006 by Infinity Interactive, Inc.
292
293 L<http://www.iinteractive.com>
294
295 This library is free software; you can redistribute it and/or modify
296 it under the same terms as Perl itself. 
297
298 =cut