lib/Mouse/Meta/Class.pm

   1 #!/usr/bin/env perl
   2 package Mouse::Meta::Class;
   3 use strict;
   4 use warnings;
   5
   6 use Scalar::Util 'blessed';
   7
   8 use MRO::Compat;
   9
  10 do {
  11     my %METACLASS_CACHE;
  12
  13     # because Mouse doesn't introspect existing classes, we're forced to
  14     # only pay attention to other Mouse classes
  15     sub _metaclass_cache {
  16         my $class = shift;
  17         my $name  = shift;
  18         return $METACLASS_CACHE{$name};
  19     }
  20
  21     sub initialize {
  22         my $class = shift;
  23         my $name  = shift;
  24         $METACLASS_CACHE{$name} = $class->new(name => $name)
  25             if !exists($METACLASS_CACHE{$name});
  26         return $METACLASS_CACHE{$name};
  27     }
  28 };
  29
  30 sub new {
  31     my $class = shift;
  32     my %args = @_;
  33
  34     $args{attributes} = {};
  35     $args{superclasses} = do {
  36         no strict 'refs';
  37         \@{ $args{name} . '::ISA' };
  38     };
  39
  40     bless \%args, $class;
  41 }
  42
  43 sub name { $_[0]->{name} }
  44
  45 sub superclasses {
  46     my $self = shift;
  47
  48     if (@_) {
  49         Mouse::load_class($_) for @_;
  50         @{ $self->{superclasses} } = @_;
  51     }
  52
  53     @{ $self->{superclasses} };
  54 }
  55
  56 sub add_attribute {
  57     my $self = shift;
  58     my $attr = shift;
  59
  60     $self->{'attributes'}{$attr->name} = $attr;
  61 }
  62
  63 sub compute_all_applicable_attributes {
  64     my $self = shift;
  65     my (@attr, %seen);
  66
  67     for my $class ($self->linearized_isa) {
  68         my $meta = $self->_metaclass_cache($class)
  69             or next;
  70
  71         for my $name (keys %{ $meta->get_attribute_map }) {
  72             next if $seen{$name}++;
  73             push @attr, $meta->get_attribute($name);
  74         }
  75     }
  76
  77     return @attr;
  78 }
  79
  80 sub get_attribute_map { $_[0]->{attributes} }
  81 sub get_attribute     { $_[0]->{attributes}->{$_[1]} }
  82
  83 sub linearized_isa { @{ mro::get_linear_isa($_[0]->name) } }
  84
  85 1;
  86
  87 __END__
  88
  89 =head1 NAME
  90
  91 Mouse::Meta::Class - hook into the Mouse MOP
  92
  93 =head1 METHODS
  94
  95 =head2 initialize ClassName -> Mouse::Meta::Class
  96
  97 Finds or creates a Mouse::Meta::Class instance for the given ClassName. Only
  98 one instance should exist for a given class.
  99
 100 =head2 new %args -> Mouse::Meta::Class
 101
 102 Creates a new Mouse::Meta::Class. Don't call this directly.
 103
 104 =head2 name -> ClassName
 105
 106 Returns the name of the owner class.
 107
 108 =head2 superclasses -> [ClassName]
 109
 110 Gets (or sets) the list of superclasses of the owner class.
 111
 112 =head2 add_attribute Mouse::Meta::Attribute
 113
 114 Begins keeping track of the existing L<Mouse::Meta::Attribute> for the owner
 115 class.
 116
 117 =head2 compute_all_applicable_attributes -> (Mouse::Meta::Attribute)
 118
 119 Returns the list of all L<Mouse::Meta::Attribute> instances associated with
 120 this class and its superclasses.
 121
 122 =head2 get_attribute_map -> { name => Mouse::Meta::Attribute }
 123
 124 Returns a mapping of attribute names to their corresponding
 125 L<Mouse::Meta::Attribute> objects.
 126
 127 =head2 get_attribute Name -> Mouse::Meta::Attribute | undef
 128
 129 Returns the L<Mouse::Meta::Attribute> with the given name.
 130
 131 =head2 linearized_isa -> [ClassNames]
 132
 133 Returns the list of classes in method dispatch order, with duplicates removed.
 134
 135 =cut
 136