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     my $pkg   = $class->name;
  52
  53     for my $name ($self->get_attribute_list) {
  54         next if $class->has_attribute($name);
  55         my $spec = $self->get_attribute($name);
  56         Mouse::Meta::Attribute->create($pkg, $name, %$spec);
  57     }
  58 }
  59
  60 1;
  61