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   strictures->import;
  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 => @_ ];
  18     };
  19   }
  20   *{_getglob "${target}::requires"} = sub {
  21     push @{$INFO{$target}{requires}||=[]}, @_;
  22   };
  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);
  26   };
  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;
  34   };
  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
  38   # is used later)
  39   @{$INFO{$target}{not_methods}={}}{
  40     '', map { *$_{CODE}||() } grep !(ref eq 'SCALAR'), values %$stash
  41   } = ();
  42   # a role does itself
  43   $APPLIED_TO{$target} = { $target => undef };
  44 }
  45
  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};
  54     +{
  55       # grab all code entries that aren't in the not_methods list
  56       map {
  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
  61     };
  62   };
  63   # grab target symbol table
  64   my $stash = do { no strict 'refs'; \%{"${to}::"}};
  65   # determine already extant methods of target
  66   my %has_methods;
  67   @has_methods{grep
  68     +((ref($stash->{$_}) eq 'SCALAR') || (*{$stash->{$_}}{CODE})),
  69     keys %$stash
  70   } = ();
  71   if (my @requires_fail
  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;
  76     } else {
  77       die "Can't apply ${role} to ${to} - missing ".join(', ', @requires_fail);
  78     }
  79   }
  80
  81   my @to_install = grep !exists $has_methods{$_}, keys %$methods;
  82   foreach my $i (@to_install) {
  83     no warnings 'once';
  84     *{_getglob "${to}::${i}"} = $methods->{$i};
  85   }
  86
  87   foreach my $modifier (@{$info->{modifiers}||[]}) {
  88     _install_modifier($to, @{$modifier});
  89   }
  90
  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;
  94   }
  95
  96   if (my $attr_info = $info->{attributes}) {
  97     if ($INFO{$to}) {
  98       @{$INFO{$to}{attributes}||={}}{keys %$attr_info} = values %$attr_info;
  99     } else {
 100       my $con = $Class::Tiny::MAKERS{$to}{constructor} ||= do {
 101         require Method::Generate::Constructor;
 102         Method::Generate::Constructor
 103           ->new(package => $to)
 104           ->install_delayed
 105           ->register_attribute_specs(do {
 106             my @spec;
 107             if (my $super = do { no strict 'refs'; ${"${to}::ISA"}[0] }) {
 108               if (my $con = $Class::Tiny::MAKERS{$super}{constructor}) {
 109                 @spec = %{$con->all_attribute_specs};
 110               }
 111             }
 112             @spec;
 113           });
 114       };
 115       $con->register_attribute_specs(%$attr_info);
 116     }
 117   }
 118
 119   # copy our role list into the target's
 120   @{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = ();
 121 }
 122
 123 sub does_role {
 124   my ($package, $role) = @_;
 125   return exists $APPLIED_TO{$package}{$role};
 126 }
 127
 128 1;