4 use Class::Method::Modifiers ();
11 # get symbol table reference
12 my $stash = do { no strict 'refs'; \%{"${target}::"} };
13 # install before/after/around subs
14 foreach my $type (qw(before after around)) {
15 *{(do { no strict 'refs'; \*{"${target}::${type}"}})} = sub {
16 push @{$INFO{$target}{modifiers}||=[]}, [ $type => @_ ];
19 *{(do { no strict 'refs'; \*{"${target}::requires"}})} = sub {
20 push @{$INFO{$target}{requires}||=[]}, @_;
22 # grab all *non-constant* (ref eq 'SCALAR') subs present
23 # in the symbol table and store their refaddrs (no need to forcibly
24 # inflate constant subs into real subs) - also add '' to here (this
26 @{$INFO{$target}{not_methods}={}}{
27 '', map { *$_{CODE}||() } grep !(ref eq 'SCALAR'), values %$stash
30 $APPLIED_TO{$target} = { $target => undef };
33 sub apply_role_to_package {
34 my ($class, $role, $to) = @_;
35 die "This is apply_role_to_package" if ref($to);
36 die "Not a Role::Tiny" unless my $info = $INFO{$role};
37 my $methods = $info->{methods} ||= do {
38 # grab role symbol table
39 my $stash = do { no strict 'refs'; \%{"${role}::"}};
40 my $not_methods = $info->{not_methods};
42 # grab all code entries that aren't in the not_methods list
44 my $code = *{$stash->{$_}}{CODE};
45 # rely on the '' key we added in import for "no code here"
46 exists $not_methods->{$code||''} ? () : ($_ => $code)
47 } grep !(ref($stash->{$_}) eq 'SCALAR'), keys %$stash
50 # grab target symbol table
51 my $stash = do { no strict 'refs'; \%{"${to}::"}};
52 # determine already extant methods of target
55 +((ref($stash->{$_}) eq 'SCALAR') || (*{$stash->{$_}}{CODE})),
59 = grep !exists $has_methods{$_}, @{$info->{requires}||[]}) {
60 # role -> role, add to requires, role -> class, error out
61 if (my $to_info = $INFO{$to}) {
62 push @{$to_info->{requires}||=[]}, @requires_fail;
64 die "Can't apply ${role} to ${to} - missing ".join(', ', @requires_fail);
68 my @to_install = grep !exists $has_methods{$_}, keys %$methods;
69 foreach my $i (@to_install) {
71 *{(do { no strict 'refs'; \*{"${to}::$i"}})}
75 foreach my $modifier (@{$info->{modifiers}||[]}) {
76 Class::Method::Modifiers::install_modifier($to, @{$modifier});
79 # copy our role list into the target's
80 @{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = ();
84 my ($package, $role) = @_;
85 return exists $APPLIED_TO{$package}{$role};