4 use Class::Method::Modifiers ();
9 sub _getglob { no strict 'refs'; \*{$_[0]} }
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 => @_ ];
21 *{_getglob "${target}::requires"} = sub {
22 push @{$INFO{$target}{requires}||=[]}, @_;
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);
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
32 @{$INFO{$target}{not_methods}={}}{
33 '', map { *$_{CODE}||() } grep !(ref eq 'SCALAR'), values %$stash
36 $APPLIED_TO{$target} = { $target => undef };
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};
48 # grab all code entries that aren't in the not_methods list
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
56 # grab target symbol table
57 my $stash = do { no strict 'refs'; \%{"${to}::"}};
58 # determine already extant methods of target
61 +((ref($stash->{$_}) eq 'SCALAR') || (*{$stash->{$_}}{CODE})),
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;
70 die "Can't apply ${role} to ${to} - missing ".join(', ', @requires_fail);
74 my @to_install = grep !exists $has_methods{$_}, keys %$methods;
75 foreach my $i (@to_install) {
77 *{_getglob "${to}::${i}"} = $methods->{$i};
80 foreach my $modifier (@{$info->{modifiers}||[]}) {
81 Class::Method::Modifiers::install_modifier($to, @{$modifier});
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;
90 # copy our role list into the target's
91 @{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = ();
95 my ($package, $role) = @_;
96 return exists $APPLIED_TO{$package}{$role};