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 has_attribute     { exists $_[0]->{attributes}->{$_[1]} }
  82 sub get_attribute     { $_[0]->{attributes}->{$_[1]} }
  83
  84 sub linearized_isa { @{ mro::get_linear_isa($_[0]->name) } }
  85
  86 1;
  87
  88 __END__
  89
  90 =head1 NAME
  91
  92 Mouse::Meta::Class - hook into the Mouse MOP
  93
  94 =head1 METHODS
  95
  96 =head2 initialize ClassName -> Mouse::Meta::Class
  97
  98 Finds or creates a Mouse::Meta::Class instance for the given ClassName. Only
  99 one instance should exist for a given class.
 100
 101 =head2 new %args -> Mouse::Meta::Class
 102
 103 Creates a new Mouse::Meta::Class. Don't call this directly.
 104
 105 =head2 name -> ClassName
 106
 107 Returns the name of the owner class.
 108
 109 =head2 superclasses -> [ClassName]
 110
 111 Gets (or sets) the list of superclasses of the owner class.
 112
 113 =head2 add_attribute Mouse::Meta::Attribute
 114
 115 Begins keeping track of the existing L<Mouse::Meta::Attribute> for the owner
 116 class.
 117
 118 =head2 compute_all_applicable_attributes -> (Mouse::Meta::Attribute)
 119
 120 Returns the list of all L<Mouse::Meta::Attribute> instances associated with
 121 this class and its superclasses.
 122
 123 =head2 get_attribute_map -> { name => Mouse::Meta::Attribute }
 124
 125 Returns a mapping of attribute names to their corresponding
 126 L<Mouse::Meta::Attribute> objects.
 127
 128 =head2 has_attribute Name -> Boool
 129
 130 Returns whether we have a L<Mouse::Meta::Attribute> with the given name.
 131
 132 =head2 get_attribute Name -> Mouse::Meta::Attribute | undef
 133
 134 Returns the L<Mouse::Meta::Attribute> with the given name.
 135
 136 =head2 linearized_isa -> [ClassNames]
 137
 138 Returns the list of classes in method dispatch order, with duplicates removed.
 139
 140 =cut
 141