lib/Role/Tiny.pm

   1 package Role::Tiny;
   2
   3 use strictures 1;
   4 use Class::Tiny::_Utils;
   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     *{_getglob "${target}::${type}"} = sub {
  16       push @{$INFO{$target}{modifiers}||=[]}, [ $type => @_ ];
  17     };
  18   }
  19   *{_getglob "${target}::requires"} = sub {
  20     push @{$INFO{$target}{requires}||=[]}, @_;
  21   };
  22   *{_getglob "${target}::with"} = sub {
  23     die "Only one role supported at a time by with" if @_ > 1;
  24     Role::Tiny->apply_role_to_package($_[0], $target);
  25   };
  26   # grab all *non-constant* (ref eq 'SCALAR') subs present
  27   # in the symbol table and store their refaddrs (no need to forcibly
  28   # inflate constant subs into real subs) - also add '' to here (this
  29   # is used later)
  30   @{$INFO{$target}{not_methods}={}}{
  31     '', map { *$_{CODE}||() } grep !(ref eq 'SCALAR'), values %$stash
  32   } = ();
  33   # a role does itself
  34   $APPLIED_TO{$target} = { $target => undef };
  35 }
  36
  37 sub apply_role_to_package {
  38   my ($class, $role, $to) = @_;
  39   die "This is apply_role_to_package" if ref($to);
  40   die "Not a Role::Tiny" unless my $info = $INFO{$role};
  41   my $methods = $info->{methods} ||= do {
  42     # grab role symbol table
  43     my $stash = do { no strict 'refs'; \%{"${role}::"}};
  44     my $not_methods = $info->{not_methods};
  45     +{
  46       # grab all code entries that aren't in the not_methods list
  47       map {
  48         my $code = *{$stash->{$_}}{CODE};
  49         # rely on the '' key we added in import for "no code here"
  50         exists $not_methods->{$code||''} ? () : ($_ => $code)
  51       } grep !(ref($stash->{$_}) eq 'SCALAR'), keys %$stash
  52     };
  53   };
  54   # grab target symbol table
  55   my $stash = do { no strict 'refs'; \%{"${to}::"}};
  56   # determine already extant methods of target
  57   my %has_methods;
  58   @has_methods{grep
  59     +((ref($stash->{$_}) eq 'SCALAR') || (*{$stash->{$_}}{CODE})),
  60     keys %$stash
  61   } = ();
  62   if (my @requires_fail
  63         = grep !exists $has_methods{$_}, @{$info->{requires}||[]}) {
  64     # role -> role, add to requires, role -> class, error out
  65     if (my $to_info = $INFO{$to}) {
  66       push @{$to_info->{requires}||=[]}, @requires_fail;
  67     } else {
  68       die "Can't apply ${role} to ${to} - missing ".join(', ', @requires_fail);
  69     }
  70   }
  71
  72   my @to_install = grep !exists $has_methods{$_}, keys %$methods;
  73   foreach my $i (@to_install) {
  74     no warnings 'once';
  75     *{_getglob "${to}::${i}"} = $methods->{$i};
  76   }
  77
  78   foreach my $modifier (@{$info->{modifiers}||[]}) {
  79     _install_modifier($to, @{$modifier});
  80   }
  81
  82   # only add does() method to classes and only if they don't have one
  83   if (not $INFO{$to} and not $to->can('does')) {
  84     ${_getglob "${to}::does"} = \&does_role;
  85   }
  86
  87
  88   # copy our role list into the target's
  89   @{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = ();
  90 }
  91
  92 sub does_role {
  93   my ($package, $role) = @_;
  94   return exists $APPLIED_TO{$package}{$role};
  95 }
  96
  97 1;