lib/Mouse/Meta/Class.pm

   1 #!/usr/bin/env perl
   2 package Mouse::Meta::Class;
   3 use strict;
   4 use warnings;
   5
   6 use Mouse::Util qw/get_linear_isa blessed/;
   7 use Carp 'confess';
   8
   9 use Class::Method::Modifiers ();
  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 { @{ 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 sub add_before_method_modifier {
 134     my ($self, $name, $code) = @_;
 135     Class::Method::Modifiers::_install_modifier(
 136         $self->name,
 137         'before',
 138         $name,
 139         $code,
 140     );
 141 }
 142
 143 sub add_around_method_modifier {
 144     my ($self, $name, $code) = @_;
 145     Class::Method::Modifiers::_install_modifier(
 146         $self->name,
 147         'around',
 148         $name,
 149         $code,
 150     );
 151 }
 152
 153 sub add_after_method_modifier {
 154     my ($self, $name, $code) = @_;
 155     Class::Method::Modifiers::_install_modifier(
 156         $self->name,
 157         'after',
 158         $name,
 159         $code,
 160     );
 161 }
 162
 163 1;
 164
 165 __END__
 166
 167 =head1 NAME
 168
 169 Mouse::Meta::Class - hook into the Mouse MOP
 170
 171 =head1 METHODS
 172
 173 =head2 initialize ClassName -> Mouse::Meta::Class
 174
 175 Finds or creates a Mouse::Meta::Class instance for the given ClassName. Only
 176 one instance should exist for a given class.
 177
 178 =head2 new %args -> Mouse::Meta::Class
 179
 180 Creates a new Mouse::Meta::Class. Don't call this directly.
 181
 182 =head2 name -> ClassName
 183
 184 Returns the name of the owner class.
 185
 186 =head2 superclasses -> [ClassName]
 187
 188 Gets (or sets) the list of superclasses of the owner class.
 189
 190 =head2 add_attribute Mouse::Meta::Attribute
 191
 192 Begins keeping track of the existing L<Mouse::Meta::Attribute> for the owner
 193 class.
 194
 195 =head2 compute_all_applicable_attributes -> (Mouse::Meta::Attribute)
 196
 197 Returns the list of all L<Mouse::Meta::Attribute> instances associated with
 198 this class and its superclasses.
 199
 200 =head2 get_attribute_map -> { name => Mouse::Meta::Attribute }
 201
 202 Returns a mapping of attribute names to their corresponding
 203 L<Mouse::Meta::Attribute> objects.
 204
 205 =head2 has_attribute Name -> Boool
 206
 207 Returns whether we have a L<Mouse::Meta::Attribute> with the given name.
 208
 209 =head2 get_attribute Name -> Mouse::Meta::Attribute | undef
 210
 211 Returns the L<Mouse::Meta::Attribute> with the given name.
 212
 213 =head2 linearized_isa -> [ClassNames]
 214
 215 Returns the list of classes in method dispatch order, with duplicates removed.
 216
 217 =head2 clone_object Instance -> Instance
 218
 219 Clones the given C<Instance> which must be an instance governed by this
 220 metaclass.
 221
 222 =head2 clone_instance Instance, Parameters -> Instance
 223
 224 Clones the given C<Instance> and sets any additional parameters.
 225
 226 =cut
 227