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 import {
  10   my $target = caller;
  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 => @_ ];
  17     };
  18   }
  19   *{(do { no strict 'refs'; \*{"${target}::requires"}})} = sub {
  20     push @{$INFO{$target}{requires}||=[]}, @_;
  21   };
  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
  25   # is used later)
  26   @{$INFO{$target}{not_methods}={}}{
  27     '', map { *$_{CODE}||() } grep !(ref eq 'SCALAR'), values %$stash
  28   } = ();
  29   # a role does itself
  30   $APPLIED_TO{$target} = { $target => undef };
  31 }
  32
  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};
  41     +{
  42       # grab all code entries that aren't in the not_methods list
  43       map {
  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
  48     };
  49   };
  50   # grab target symbol table
  51   my $stash = do { no strict 'refs'; \%{"${to}::"}};
  52   # determine already extant methods of target
  53   my %has_methods;
  54   @has_methods{grep
  55     +((ref($stash->{$_}) eq 'SCALAR') || (*{$stash->{$_}}{CODE})),
  56     keys %$stash
  57   } = ();
  58   if (my @requires_fail
  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;
  63     } else {
  64       die "Can't apply ${role} to ${to} - missing ".join(', ', @requires_fail);
  65     }
  66   }
  67
  68   my @to_install = grep !exists $has_methods{$_}, keys %$methods;
  69   foreach my $i (@to_install) {
  70     no warnings 'once';
  71     *{(do { no strict 'refs'; \*{"${to}::$i"}})}
  72       = $methods->{$i};
  73   }
  74
  75   foreach my $modifier (@{$info->{modifiers}||[]}) {
  76     Class::Method::Modifiers::install_modifier($to, @{$modifier});
  77   }
  78
  79   # copy our role list into the target's
  80   @{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = ();
  81 }
  82
  83 sub does_role {
  84   my ($package, $role) = @_;
  85   return exists $APPLIED_TO{$package}{$role};
  86 }
  87
  88 1;