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 use Carp 'confess';
   8
   9 use MRO::Compat;
  10
  11 do {
  12     my %METACLASS_CACHE;
  13
  14     # because Mouse doesn't introspect existing classes, we're forced to
  15     # only pay attention to other Mouse classes
  16     sub _metaclass_cache {
  17         my $class = shift;
  18         my $name  = shift;
  19         return $METACLASS_CACHE{$name};
  20     }
  21
  22     sub initialize {
  23         my $class = shift;
  24         my $name  = shift;
  25         $METACLASS_CACHE{$name} = $class->new(name => $name)
  26             if !exists($METACLASS_CACHE{$name});
  27         return $METACLASS_CACHE{$name};
  28     }
  29 };
  30
  31 sub new {
  32     my $class = shift;
  33     my %args  = @_;
  34
  35     $args{attributes} = {};
  36     $args{superclasses} = do {
  37         no strict 'refs';
  38         \@{ $args{name} . '::ISA' };
  39     };
  40
  41     bless \%args, $class;
  42 }
  43
  44 sub name { $_[0]->{name} }
  45
  46 sub superclasses {
  47     my $self = shift;
  48
  49     if (@_) {
  50         Mouse::load_class($_) for @_;
  51         @{ $self->{superclasses} } = @_;
  52     }
  53
  54     @{ $self->{superclasses} };
  55 }
  56
  57 sub add_attribute {
  58     my $self = shift;
  59     my $attr = shift;
  60
  61     $self->{'attributes'}{$attr->name} = $attr;
  62 }
  63
  64 sub compute_all_applicable_attributes {
  65     my $self = shift;
  66     my (@attr, %seen);
  67
  68     for my $class ($self->linearized_isa) {
  69         my $meta = $self->_metaclass_cache($class)
  70             or next;
  71
  72         for my $name (keys %{ $meta->get_attribute_map }) {
  73             next if $seen{$name}++;
  74             push @attr, $meta->get_attribute($name);
  75         }
  76     }
  77
  78     return @attr;
  79 }
  80
  81 sub get_attribute_map { $_[0]->{attributes} }
  82 sub has_attribute     { exists $_[0]->{attributes}->{$_[1]} }
  83 sub get_attribute     { $_[0]->{attributes}->{$_[1]} }
  84
  85 sub linearized_isa { @{ mro::get_linear_isa($_[0]->name) } }
  86
  87 sub clone_object {
  88     my $class    = shift;
  89     my $instance = shift;
  90
  91     (blessed($instance) && $instance->isa($class->name))
  92         || confess "You must pass an instance ($instance) of the metaclass (" . $class->name . ")";
  93
  94     $class->clone_instance($instance, @_);
  95 }
  96
  97 sub clone_instance {
  98     my ($class, $instance, %params) = @_;
  99
 100     (blessed($instance))
 101         || confess "You can only clone instances, \$self is not a blessed instance";
 102
 103     my $clone = bless { %$instance }, ref $instance;
 104
 105     foreach my $attr ($class->compute_all_applicable_attributes()) {
 106         if ( defined( my $init_arg = $attr->init_arg ) ) {
 107             if (exists $params{$init_arg}) {
 108                 $clone->{ $attr->name } = $params{$init_arg};
 109             }
 110         }
 111     }
 112
 113     return $clone;
 114
 115 }
 116
 117
 118 1;
 119
 120 __END__
 121
 122 =head1 NAME
 123
 124 Mouse::Meta::Class - hook into the Mouse MOP
 125
 126 =head1 METHODS
 127
 128 =head2 initialize ClassName -> Mouse::Meta::Class
 129
 130 Finds or creates a Mouse::Meta::Class instance for the given ClassName. Only
 131 one instance should exist for a given class.
 132
 133 =head2 new %args -> Mouse::Meta::Class
 134
 135 Creates a new Mouse::Meta::Class. Don't call this directly.
 136
 137 =head2 name -> ClassName
 138
 139 Returns the name of the owner class.
 140
 141 =head2 superclasses -> [ClassName]
 142
 143 Gets (or sets) the list of superclasses of the owner class.
 144
 145 =head2 add_attribute Mouse::Meta::Attribute
 146
 147 Begins keeping track of the existing L<Mouse::Meta::Attribute> for the owner
 148 class.
 149
 150 =head2 compute_all_applicable_attributes -> (Mouse::Meta::Attribute)
 151
 152 Returns the list of all L<Mouse::Meta::Attribute> instances associated with
 153 this class and its superclasses.
 154
 155 =head2 get_attribute_map -> { name => Mouse::Meta::Attribute }
 156
 157 Returns a mapping of attribute names to their corresponding
 158 L<Mouse::Meta::Attribute> objects.
 159
 160 =head2 has_attribute Name -> Boool
 161
 162 Returns whether we have a L<Mouse::Meta::Attribute> with the given name.
 163
 164 =head2 get_attribute Name -> Mouse::Meta::Attribute | undef
 165
 166 Returns the L<Mouse::Meta::Attribute> with the given name.
 167
 168 =head2 linearized_isa -> [ClassNames]
 169
 170 Returns the list of classes in method dispatch order, with duplicates removed.
 171
 172 =cut
 173