lib/Mouse/Meta/Role.pm

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