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 *{_getglob "${target}::has"} = sub {
28 my ($name, %spec) = @_;
29 ($INFO{$target}{accessor_maker} ||= do {
30 require Method::Generate::Accessor;
31 Method::Generate::Accessor->new
32 })->generate_method($target, $name, \%spec);
33 $INFO{$target}{attributes}{$name} = \%spec;
35 # grab all *non-constant* (ref eq 'SCALAR') subs present
36 # in the symbol table and store their refaddrs (no need to forcibly
37 # inflate constant subs into real subs) - also add '' to here (this
39 @{$INFO{$target}{not_methods}={}}{
40 '', map { *$_{CODE}||() } grep !(ref eq 'SCALAR'), values %$stash
43 $APPLIED_TO{$target} = { $target => undef };
46 sub apply_role_to_package {
47 my ($class, $role, $to) = @_;
48 die "This is apply_role_to_package" if ref($to);
49 die "Not a Role::Tiny" unless my $info = $INFO{$role};
50 my $methods = $info->{methods} ||= do {
51 # grab role symbol table
52 my $stash = do { no strict 'refs'; \%{"${role}::"}};
53 my $not_methods = $info->{not_methods};
55 # grab all code entries that aren't in the not_methods list
57 my $code = *{$stash->{$_}}{CODE};
58 # rely on the '' key we added in import for "no code here"
59 exists $not_methods->{$code||''} ? () : ($_ => $code)
60 } grep !(ref($stash->{$_}) eq 'SCALAR'), keys %$stash
63 # grab target symbol table
64 my $stash = do { no strict 'refs'; \%{"${to}::"}};
65 # determine already extant methods of target
68 +((ref($stash->{$_}) eq 'SCALAR') || (*{$stash->{$_}}{CODE})),
72 = grep !exists $has_methods{$_}, @{$info->{requires}||[]}) {
73 # role -> role, add to requires, role -> class, error out
74 if (my $to_info = $INFO{$to}) {
75 push @{$to_info->{requires}||=[]}, @requires_fail;
77 die "Can't apply ${role} to ${to} - missing ".join(', ', @requires_fail);
81 my @to_install = grep !exists $has_methods{$_}, keys %$methods;
82 foreach my $i (@to_install) {
84 *{_getglob "${to}::${i}"} = $methods->{$i};
87 foreach my $modifier (@{$info->{modifiers}||[]}) {
88 _install_modifier($to, @{$modifier});
91 # only add does() method to classes and only if they don't have one
92 if (not $INFO{$to} and not $to->can('does')) {
93 ${_getglob "${to}::does"} = \&does_role;
96 if (my $attr_info = $info->{attributes}) {
98 @{$INFO{$to}{attributes}||={}}{keys %$attr_info} = values %$attr_info;
100 # only fiddle with the constructor if the target is a Class::Tiny class
101 if (my $con = Class::Tiny->_constructor_maker_for($to)) {
102 $con->register_attribute_specs(%$attr_info);
107 # copy our role list into the target's
108 @{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = ();
112 my ($package, $role) = @_;
113 return exists $APPLIED_TO{$package}{$role};