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_method {
  58     my $self = shift;
  59     my $name = shift;
  60     my $code = shift;
  61
  62     my $pkg = $self->name;
  63
  64     no strict 'refs';
  65     *{ $pkg . '::' . $name } = $code;
  66 }
  67
  68 sub add_attribute {
  69     my $self = shift;
  70     my $attr = shift;
  71
  72     $self->{'attributes'}{$attr->name} = $attr;
  73 }
  74
  75 sub compute_all_applicable_attributes {
  76     my $self = shift;
  77     my (@attr, %seen);
  78
  79     for my $class ($self->linearized_isa) {
  80         my $meta = $self->_metaclass_cache($class)
  81             or next;
  82
  83         for my $name (keys %{ $meta->get_attribute_map }) {
  84             next if $seen{$name}++;
  85             push @attr, $meta->get_attribute($name);
  86         }
  87     }
  88
  89     return @attr;
  90 }
  91
  92 sub get_attribute_map { $_[0]->{attributes} }
  93 sub has_attribute     { exists $_[0]->{attributes}->{$_[1]} }
  94 sub get_attribute     { $_[0]->{attributes}->{$_[1]} }
  95
  96 sub linearized_isa { @{ mro::get_linear_isa($_[0]->name) } }
  97
  98 sub clone_object {
  99     my $class    = shift;
 100     my $instance = shift;
 101
 102     (blessed($instance) && $instance->isa($class->name))
 103         || confess "You must pass an instance of the metaclass (" . $class->name . "), not ($instance)";
 104
 105     $class->clone_instance($instance, @_);
 106 }
 107
 108 sub clone_instance {
 109     my ($class, $instance, %params) = @_;
 110
 111     (blessed($instance))
 112         || confess "You can only clone instances, ($instance) is not a blessed instance";
 113
 114     my $clone = bless { %$instance }, ref $instance;
 115
 116     foreach my $attr ($class->compute_all_applicable_attributes()) {
 117         if ( defined( my $init_arg = $attr->init_arg ) ) {
 118             if (exists $params{$init_arg}) {
 119                 $clone->{ $attr->name } = $params{$init_arg};
 120             }
 121         }
 122     }
 123
 124     return $clone;
 125
 126 }
 127
 128 sub make_immutable {}
 129 sub is_immutable { 0 }
 130
 131 sub attribute_metaclass { "Mouse::Meta::Class" }
 132
 133 1;
 134
 135 __END__
 136
 137 =head1 NAME
 138
 139 Mouse::Meta::Class - hook into the Mouse MOP
 140
 141 =head1 METHODS
 142
 143 =head2 initialize ClassName -> Mouse::Meta::Class
 144
 145 Finds or creates a Mouse::Meta::Class instance for the given ClassName. Only
 146 one instance should exist for a given class.
 147
 148 =head2 new %args -> Mouse::Meta::Class
 149
 150 Creates a new Mouse::Meta::Class. Don't call this directly.
 151
 152 =head2 name -> ClassName
 153
 154 Returns the name of the owner class.
 155
 156 =head2 superclasses -> [ClassName]
 157
 158 Gets (or sets) the list of superclasses of the owner class.
 159
 160 =head2 add_attribute Mouse::Meta::Attribute
 161
 162 Begins keeping track of the existing L<Mouse::Meta::Attribute> for the owner
 163 class.
 164
 165 =head2 compute_all_applicable_attributes -> (Mouse::Meta::Attribute)
 166
 167 Returns the list of all L<Mouse::Meta::Attribute> instances associated with
 168 this class and its superclasses.
 169
 170 =head2 get_attribute_map -> { name => Mouse::Meta::Attribute }
 171
 172 Returns a mapping of attribute names to their corresponding
 173 L<Mouse::Meta::Attribute> objects.
 174
 175 =head2 has_attribute Name -> Boool
 176
 177 Returns whether we have a L<Mouse::Meta::Attribute> with the given name.
 178
 179 =head2 get_attribute Name -> Mouse::Meta::Attribute | undef
 180
 181 Returns the L<Mouse::Meta::Attribute> with the given name.
 182
 183 =head2 linearized_isa -> [ClassNames]
 184
 185 Returns the list of classes in method dispatch order, with duplicates removed.
 186
 187 =head2 clone_object Instance -> Instance
 188
 189 Clones the given C<Instance> which must be an instance governed by this
 190 metaclass.
 191
 192 =head2 clone_instance Instance, Parameters -> Instance
 193
 194 Clones the given C<Instance> and sets any additional parameters.
 195
 196 =cut
 197