788309945046e3fd5a5a99e9e9728b3d1fb5c589
[gitmo/Moo.git] / lib / Role / Tiny.pm
1 package Role::Tiny;
2
3 use strictures 1;
4 use Class::Method::Modifiers ();
5
6 our %INFO;
7 our %APPLIED_TO;
8
9 sub _getglob { no strict 'refs'; \*{$_[0]} }
10
11 sub import {
12   my $target = caller;
13   # get symbol table reference
14   my $stash = do { no strict 'refs'; \%{"${target}::"} };
15   # install before/after/around subs
16   foreach my $type (qw(before after around)) {
17     *{_getglob "${target}::${type}"} = sub {
18       push @{$INFO{$target}{modifiers}||=[]}, [ $type => @_ ];
19     };
20   }
21   *{_getglob "${target}::requires"} = sub {
22     push @{$INFO{$target}{requires}||=[]}, @_;
23   };
24   *{_getglob "${target}::with"} = sub {
25     die "Only one role supported at a time by with" if @_ > 1;
26     Role::Tiny->apply_role_to_package($_[0], $target);
27   };
28   # grab all *non-constant* (ref eq 'SCALAR') subs present
29   # in the symbol table and store their refaddrs (no need to forcibly
30   # inflate constant subs into real subs) - also add '' to here (this
31   # is used later)
32   @{$INFO{$target}{not_methods}={}}{
33     '', map { *$_{CODE}||() } grep !(ref eq 'SCALAR'), values %$stash
34   } = ();
35   # a role does itself
36   $APPLIED_TO{$target} = { $target => undef };
37 }
38
39 sub apply_role_to_package {
40   my ($class, $role, $to) = @_;
41   die "This is apply_role_to_package" if ref($to);
42   die "Not a Role::Tiny" unless my $info = $INFO{$role};
43   my $methods = $info->{methods} ||= do {
44     # grab role symbol table
45     my $stash = do { no strict 'refs'; \%{"${role}::"}};
46     my $not_methods = $info->{not_methods};
47     +{
48       # grab all code entries that aren't in the not_methods list
49       map {
50         my $code = *{$stash->{$_}}{CODE};
51         # rely on the '' key we added in import for "no code here"
52         exists $not_methods->{$code||''} ? () : ($_ => $code)
53       } grep !(ref($stash->{$_}) eq 'SCALAR'), keys %$stash
54     };
55   };
56   # grab target symbol table
57   my $stash = do { no strict 'refs'; \%{"${to}::"}};
58   # determine already extant methods of target
59   my %has_methods;
60   @has_methods{grep
61     +((ref($stash->{$_}) eq 'SCALAR') || (*{$stash->{$_}}{CODE})),
62     keys %$stash
63   } = ();
64   if (my @requires_fail
65         = grep !exists $has_methods{$_}, @{$info->{requires}||[]}) {
66     # role -> role, add to requires, role -> class, error out
67     if (my $to_info = $INFO{$to}) {
68       push @{$to_info->{requires}||=[]}, @requires_fail;
69     } else {
70       die "Can't apply ${role} to ${to} - missing ".join(', ', @requires_fail);
71     }
72   }
73
74   my @to_install = grep !exists $has_methods{$_}, keys %$methods;
75   foreach my $i (@to_install) {
76     no warnings 'once';
77     *{_getglob "${to}::${i}"} = $methods->{$i};
78   }
79
80   foreach my $modifier (@{$info->{modifiers}||[]}) {
81     Class::Method::Modifiers::install_modifier($to, @{$modifier});
82   }
83
84   # only add does() method to classes and only if they don't have one
85   if (not $INFO{$to} and not $to->can('does')) {
86     ${_getglob "${to}::does"} = \&does_role;
87   }
88     
89
90   # copy our role list into the target's
91   @{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = ();
92 }
93
94 sub does_role {
95   my ($package, $role) = @_;
96   return exists $APPLIED_TO{$package}{$role};
97 }
98
99 1;