1c7b051e8849706e7bdecef9ac408f8b74ae7c9c
[gitmo/Moo.git] / lib / Role / Tiny.pm
1 package Role::Tiny;
2
3 sub _getglob { \*{$_[0]} }
4
5 use strict;
6 use warnings FATAL => 'all';
7
8 our %INFO;
9 our %APPLIED_TO;
10 our %COMPOSED;
11
12 sub _load_module {
13   return 1 if $_[0]->can('can');
14   (my $proto = $_[0]) =~ s/::/\//g;
15   require "${proto}.pm";
16   return 1;
17 }
18
19 sub import {
20   my $target = caller;
21   my $me = $_[0];
22   strictures->import;
23   return if $INFO{$target}; # already exported into this package
24   # get symbol table reference
25   my $stash = do { no strict 'refs'; \%{"${target}::"} };
26   # install before/after/around subs
27   foreach my $type (qw(before after around)) {
28     *{_getglob "${target}::${type}"} = sub {
29       require Class::Method::Modifiers;
30       push @{$INFO{$target}{modifiers}||=[]}, [ $type => @_ ];
31     };
32   }
33   *{_getglob "${target}::requires"} = sub {
34     push @{$INFO{$target}{requires}||=[]}, @_;
35   };
36   *{_getglob "${target}::with"} = sub {
37     die "Only one role supported at a time by with" if @_ > 1;
38     $me->apply_role_to_package($target, $_[0]);
39   };
40   # grab all *non-constant* (ref eq 'SCALAR') subs present
41   # in the symbol table and store their refaddrs (no need to forcibly
42   # inflate constant subs into real subs) - also add '' to here (this
43   # is used later)
44   @{$INFO{$target}{not_methods}={}}{
45     '', map { *$_{CODE}||() } grep !(ref eq 'SCALAR'), values %$stash
46   } = ();
47   # a role does itself
48   $APPLIED_TO{$target} = { $target => undef };
49 }
50
51 sub apply_role_to_package {
52   my ($me, $to, $role) = @_;
53
54   _load_module($role);
55
56   die "This is apply_role_to_package" if ref($to);
57   die "${role} is not a Role::Tiny" unless my $info = $INFO{$role};
58
59   $me->_check_requires($to, $role, @{$info->{requires}||[]});
60
61   $me->_install_methods($to, $role);
62
63   $me->_install_modifiers($to, $info->{modifiers});
64
65   # only add does() method to classes and only if they don't have one
66   if (not $INFO{$to} and not $to->can('does')) {
67     *{_getglob "${to}::does"} = \&does_role;
68   }
69
70   # copy our role list into the target's
71   @{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = ();
72 }
73
74 sub apply_roles_to_object {
75   my ($me, $object, @roles) = @_;
76   die "No roles supplied!" unless @roles;
77   my $class = ref($object);
78   bless($object, $me->create_class_with_roles($class, @roles));
79   $object;
80 }
81
82 sub create_class_with_roles {
83   my ($me, $superclass, @roles) = @_;
84
85   die "No roles supplied!" unless @roles;
86
87   my $new_name = join('+', $superclass, my $compose_name = join '+', @roles);
88   return $new_name if $COMPOSED{class}{$new_name};
89
90   foreach my $role (@roles) {
91     _load_module($role);
92     die "${role} is not a Role::Tiny" unless my $info = $INFO{$role};
93   }
94
95   if ($] >= 5.010) {
96     require mro;
97   } else {
98     require MRO::Compat;
99   }
100
101   my @composable = map $me->_composable_package_for($_), reverse @roles;
102
103   *{_getglob("${new_name}::ISA")} = [ @composable, $superclass ];
104
105   my @info = map +($INFO{$_} ? $INFO{$_} : ()), @roles;
106
107   $me->_check_requires(
108     $new_name, $compose_name,
109     do { my %h; @h{map @{$_->{requires}||[]}, @info} = (); keys %h }
110   );
111
112   *{_getglob "${new_name}::does"} = \&does_role unless $new_name->can('does');
113
114   @{$APPLIED_TO{$new_name}||={}}{
115     map keys %{$APPLIED_TO{$_}}, @roles
116   } = ();
117
118   $COMPOSED{class}{$new_name} = 1;
119   return $new_name;
120 }
121
122 sub _composable_package_for {
123   my ($me, $role) = @_;
124   my $composed_name = 'Role::Tiny::_COMPOSABLE::'.$role;
125   return $composed_name if $COMPOSED{role}{$composed_name};
126   $me->_install_methods($composed_name, $role);
127   my $base_name = $composed_name.'::_BASE';
128   *{_getglob("${composed_name}::ISA")} = [ $base_name ];
129   my $modifiers = $INFO{$role}{modifiers}||[];
130   my @mod_base;
131   foreach my $modified (
132     do { my %h; @h{map $_->[1], @$modifiers} = (); keys %h }
133   ) {
134     push @mod_base, "sub ${modified} { shift->next::method(\@_) }";
135   }
136   eval(my $code = join "\n", "package ${base_name};", @mod_base);
137   die "Evaling failed: $@\nTrying to eval:\n${code}" if $@;
138   $me->_install_modifiers($composed_name, $modifiers);
139   $COMPOSED{role}{$composed_name} = 1;
140   return $composed_name;
141 }
142
143 sub _check_requires {
144   my ($me, $to, $name, @requires) = @_;
145   if (my @requires_fail = grep !$to->can($_), @requires) {
146     # role -> role, add to requires, role -> class, error out
147     if (my $to_info = $INFO{$to}) {
148       push @{$to_info->{requires}||=[]}, @requires_fail;
149     } else {
150       die "Can't apply ${name} to ${to} - missing ".join(', ', @requires_fail);
151     }
152   }
153 }
154
155 sub _concrete_methods_of {
156   my ($me, $role) = @_;
157   my $info = $INFO{$role};
158   $info->{methods} ||= do {
159     # grab role symbol table
160     my $stash = do { no strict 'refs'; \%{"${role}::"}};
161     my $not_methods = $info->{not_methods};
162     +{
163       # grab all code entries that aren't in the not_methods list
164       map {
165         my $code = *{$stash->{$_}}{CODE};
166         # rely on the '' key we added in import for "no code here"
167         exists $not_methods->{$code||''} ? () : ($_ => $code)
168       } grep !(ref($stash->{$_}) eq 'SCALAR'), keys %$stash
169     };
170   };
171 }
172
173 sub methods_provided_by {
174   my ($me, $role) = @_;
175   die "${role} is not a Role::Tiny" unless my $info = $INFO{$role};
176   (keys %{$me->_concrete_methods_of($role)}, @{$info->{requires}||[]});
177 }
178
179 sub _install_methods {
180   my ($me, $to, $role) = @_;
181
182   my $info = $INFO{$role};
183
184   my $methods = $me->_concrete_methods_of($role);
185
186   # grab target symbol table
187   my $stash = do { no strict 'refs'; \%{"${to}::"}};
188
189   # determine already extant methods of target
190   my %has_methods;
191   @has_methods{grep
192     +((ref($stash->{$_}) eq 'SCALAR') || (*{$stash->{$_}}{CODE})),
193     keys %$stash
194   } = ();
195
196   foreach my $i (grep !exists $has_methods{$_}, keys %$methods) {
197     no warnings 'once';
198     *{_getglob "${to}::${i}"} = $methods->{$i};
199   }
200 }
201
202 sub _install_modifiers {
203   my ($me, $to, $modifiers) = @_;
204   if (my $info = $INFO{$to}) {
205     push @{$info->{modifiers}}, @{$modifiers||[]};
206   } else {
207     foreach my $modifier (@{$modifiers||[]}) {
208       $me->_install_single_modifier($to, @$modifier);
209     }
210   }
211 }
212
213 sub _install_single_modifier {
214   my ($me, @args) = @_;
215   Class::Method::Modifiers::install_modifier(@args);
216 }
217
218 sub does_role {
219   my ($proto, $role) = @_;
220   return exists $APPLIED_TO{ref($proto)||$proto}{$role};
221 }
222
223 1;
224
225 =head1 NAME
226
227 Role::Tiny - Roles. Like a nouvelle cusine portion size slice of Moose.
228
229 =head1 SYNOPSIS
230
231  package Some::Role;
232
233  use Role::Tiny;
234
235  sub foo { ... }
236
237  sub bar { ... }
238
239  1;
240
241 else where
242
243  package Some::Class;
244
245  require Role::Tiny;
246
247  # bar gets imported, but not foo
248  Role::Tiny->apply_role_to_package('Some::Role', __PACKAGE__);
249
250  sub foo { ... }
251
252  1;
253
254 =head1 DESCRIPTION
255
256 C<Role::Tiny> is a minimalist role composition tool.
257
258 =head1 ROLE COMPOSITION
259
260 Role composition can be thought of as much more clever and meaningful multiple
261 inheritance.  The basics of this implementation of roles is:
262
263 =over 2
264
265 =item *
266
267 If a method is already defined on a class, that method will not be composed in
268 from the role.
269
270 =item *
271
272 If a method that the role L</requires> to be implemented is not implemented,
273 role application will fail loudly.
274
275 =back
276
277 Unlike L<Class::C3>, where the B<last> class inherited from "wins," role
278 composition is the other way around, where first wins.  In a more complete
279 system (see L<Moose>) roles are checked to see if they clash.  The goal of this
280 is to be much simpler, hence disallowing composition of multiple roles at once.
281
282 =head1 METHODS
283
284 =head2 apply_role_to_package
285
286  Role::Tiny->apply_role_to_package('Some::Package', 'Some::Role');
287
288 Composes role with package
289
290 =head2 apply_roles_to_object
291
292  Role::Tiny->apply_roles_to_object($foo, qw(Some::Role1 Some::Role2));
293
294 Composes roles in order into object directly.  Object is reblessed into the
295 resulting class.
296
297 =head2 create_class_with_roles
298
299  Role::Tiny->create_class_with_roles('Some::Base', qw(Some::Role1 Some::Role2));
300
301 Creates a new class based on base, with the roles composed into it in order.
302 New class is returned.
303
304 =head1 SUBROUTINES
305
306 =head2 does_role
307
308  if (Role::Tiny::does_role($foo, 'Some::Role')) {
309    ...
310  }
311
312 Returns true if class has been composed with role.
313
314 This subroutine is also installed as ->does on any class a Role::Tiny is
315 composed into unless that class already has an ->does method, so
316
317   if ($foo->does_role('Some::Role')) {
318     ...
319   }
320
321 will work for classes but to test a role, one must use ::does_role directly
322
323 =head1 IMPORTED SUBROUTINES
324
325 =head2 requires
326
327  requires qw(foo bar);
328
329 Declares a list of methods that must be defined to compose role.
330
331 =head2 with
332
333  with 'Some::Role1';
334  with 'Some::Role2';
335
336 Composes another role into the current role.  Only one role may be composed in
337 at a time to allow the code to remain as simple as possible.
338
339 =head2 before
340
341  before foo => sub { ... };
342
343 See L<< Class::Method::Modifiers/before method(s) => sub { ... } >> for full
344 documentation.
345
346 =head2 around
347
348  around foo => sub { ... };
349
350 See L<< Class::Method::Modifiers/around method(s) => sub { ... } >> for full
351 documentation.
352
353 =head2 after
354
355  after foo => sub { ... };
356
357 See L<< Class::Method::Modifiers/after method(s) => sub { ... } >> for full
358 documentation.
359