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     $self->{attributes}->{$name} = [ @_ ];
  41 }
  42
  43 sub has_attribute { exists $_[0]->{attributes}->{$_[1]}  }
  44 sub get_attribute_list { keys %{ $_[0]->{attributes} } }
  45 sub get_attribute { @{ $_->[0]->{attributes}->{$_[1]} || [] } }
  46
  47 sub apply {
  48     my $self  = shift;
  49     my $class = shift;
  50     my $pkg   = $class->name;
  51
  52     for my $name ($self->get_attribute_list) {
  53         my @spec = $self->get_attribute($name);
  54         Mouse::Meta::Attribute->create($pkg, $name, @spec);
  55     }
  56 }
  57
  58 1;
  59