4 use Class::Tiny::_Utils;
12 # get symbol table reference
13 my $stash = do { no strict 'refs'; \%{"${target}::"} };
14 # install before/after/around subs
15 foreach my $type (qw(before after around)) {
16 *{_getglob "${target}::${type}"} = sub {
17 push @{$INFO{$target}{modifiers}||=[]}, [ $type => @_ ];
20 *{_getglob "${target}::requires"} = sub {
21 push @{$INFO{$target}{requires}||=[]}, @_;
23 *{_getglob "${target}::with"} = sub {
24 die "Only one role supported at a time by with" if @_ > 1;
25 Role::Tiny->apply_role_to_package($_[0], $target);
27 # grab all *non-constant* (ref eq 'SCALAR') subs present
28 # in the symbol table and store their refaddrs (no need to forcibly
29 # inflate constant subs into real subs) - also add '' to here (this
31 @{$INFO{$target}{not_methods}={}}{
32 '', map { *$_{CODE}||() } grep !(ref eq 'SCALAR'), values %$stash
35 $APPLIED_TO{$target} = { $target => undef };
38 sub apply_role_to_package {
39 my ($class, $role, $to) = @_;
40 die "This is apply_role_to_package" if ref($to);
41 die "Not a Role::Tiny" unless my $info = $INFO{$role};
42 my $methods = $info->{methods} ||= do {
43 # grab role symbol table
44 my $stash = do { no strict 'refs'; \%{"${role}::"}};
45 my $not_methods = $info->{not_methods};
47 # grab all code entries that aren't in the not_methods list
49 my $code = *{$stash->{$_}}{CODE};
50 # rely on the '' key we added in import for "no code here"
51 exists $not_methods->{$code||''} ? () : ($_ => $code)
52 } grep !(ref($stash->{$_}) eq 'SCALAR'), keys %$stash
55 # grab target symbol table
56 my $stash = do { no strict 'refs'; \%{"${to}::"}};
57 # determine already extant methods of target
60 +((ref($stash->{$_}) eq 'SCALAR') || (*{$stash->{$_}}{CODE})),
64 = grep !exists $has_methods{$_}, @{$info->{requires}||[]}) {
65 # role -> role, add to requires, role -> class, error out
66 if (my $to_info = $INFO{$to}) {
67 push @{$to_info->{requires}||=[]}, @requires_fail;
69 die "Can't apply ${role} to ${to} - missing ".join(', ', @requires_fail);
73 my @to_install = grep !exists $has_methods{$_}, keys %$methods;
74 foreach my $i (@to_install) {
76 *{_getglob "${to}::${i}"} = $methods->{$i};
79 foreach my $modifier (@{$info->{modifiers}||[]}) {
80 _install_modifier($to, @{$modifier});
83 # only add does() method to classes and only if they don't have one
84 if (not $INFO{$to} and not $to->can('does')) {
85 ${_getglob "${to}::does"} = \&does_role;
89 # copy our role list into the target's
90 @{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = ();
94 my ($package, $role) = @_;
95 return exists $APPLIED_TO{$package}{$role};