lib/Mouse/Meta/Role.pm

   1 #!/usr/bin/env perl
   2 package Mouse::Meta::Role;
   3 use strict;
   4 use warnings;
   5 use Carp 'confess';
   6
   7 do {
   8     my %METACLASS_CACHE;
   9
  10     # because Mouse doesn't introspect existing classes, we're forced to
  11     # only pay attention to other Mouse classes
  12     sub _metaclass_cache {
  13         my $class = shift;
  14         my $name  = shift;
  15         return $METACLASS_CACHE{$name};
  16     }
  17
  18     sub initialize {
  19         my $class = shift;
  20         my $name  = shift;
  21         $METACLASS_CACHE{$name} = $class->new(name => $name)
  22             if !exists($METACLASS_CACHE{$name});
  23         return $METACLASS_CACHE{$name};
  24     }
  25 };
  26
  27 sub new {
  28     my $class = shift;
  29     my %args  = @_;
  30
  31     $args{attributes}       ||= {};
  32     $args{required_methods} ||= [];
  33
  34     bless \%args, $class;
  35 }
  36
  37 sub name { $_[0]->{name} }
  38
  39 sub add_required_methods {
  40     my $self = shift;
  41     my @methods = @_;
  42     push @{$self->{required_methods}}, @methods;
  43 }
  44
  45 sub add_attribute {
  46     my $self = shift;
  47     my $name = shift;
  48     my $spec = shift;
  49     $self->{attributes}->{$name} = $spec;
  50 }
  51
  52 sub has_attribute { exists $_[0]->{attributes}->{$_[1]}  }
  53 sub get_attribute_list { keys %{ $_[0]->{attributes} } }
  54 sub get_attribute { $_[0]->{attributes}->{$_[1]} }
  55
  56 sub apply {
  57     my $self  = shift;
  58     my $class = shift;
  59
  60     for my $name (@{$self->{required_methods}}) {
  61         unless ($class->name->can($name)) {
  62             confess "'@{[ $self->name ]}' requires the method '$name' to be implemented by '@{[ $class->name ]}'";
  63         }
  64     }
  65
  66     for my $name ($self->get_attribute_list) {
  67         next if $class->has_attribute($name);
  68         my $spec = $self->get_attribute($name);
  69         Mouse::Meta::Attribute->create($class, $name, %$spec);
  70     }
  71
  72     for my $modifier_type (qw/before after around/) {
  73         my $add_method = "add_${modifier_type}_method_modifier";
  74         my $modified = $self->{"${modifier_type}_method_modifiers"};
  75
  76         for my $method_name (keys %$modified) {
  77             for my $code (@{ $modified->{$method_name} }) {
  78                 $class->$add_method($method_name => $code);
  79             }
  80         }
  81     }
  82 }
  83
  84 for my $modifier_type (qw/before after around/) {
  85     no strict 'refs';
  86     *{ __PACKAGE__ . '::' . "add_${modifier_type}_method_modifier" } = sub {
  87         my ($self, $method_name, $method) = @_;
  88
  89         push @{ $self->{"${modifier_type}_method_modifiers"}->{$method_name} },
  90             $method;
  91     };
  92
  93     *{ __PACKAGE__ . '::' . "get_${modifier_type}_method_modifiers" } = sub {
  94         my ($self, $method_name, $method) = @_;
  95         @{ $self->{"${modifier_type}_method_modifiers"}->{$method_name} || [] }
  96     };
  97 }
  98
  99 1;
 100