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 do {
  10     my %METACLASS_CACHE;
  11
  12     # because Mouse doesn't introspect existing classes, we're forced to
  13     # only pay attention to other Mouse classes
  14     sub _metaclass_cache {
  15         my $class = shift;
  16         my $name  = shift;
  17         return $METACLASS_CACHE{$name};
  18     }
  19
  20     sub initialize {
  21         my $class = shift;
  22         my $name  = shift;
  23         $METACLASS_CACHE{$name} = $class->new(name => $name)
  24             if !exists($METACLASS_CACHE{$name});
  25         return $METACLASS_CACHE{$name};
  26     }
  27 };
  28
  29 sub new {
  30     my $class = shift;
  31     my %args  = @_;
  32
  33     $args{attributes} = {};
  34     $args{superclasses} = do {
  35         no strict 'refs';
  36         \@{ $args{name} . '::ISA' };
  37     };
  38
  39     bless \%args, $class;
  40 }
  41
  42 sub name { $_[0]->{name} }
  43
  44 sub superclasses {
  45     my $self = shift;
  46
  47     if (@_) {
  48         Mouse::load_class($_) for @_;
  49         @{ $self->{superclasses} } = @_;
  50     }
  51
  52     @{ $self->{superclasses} };
  53 }
  54
  55 sub add_method {
  56     my $self = shift;
  57     my $name = shift;
  58     my $code = shift;
  59
  60     my $pkg = $self->name;
  61
  62     no strict 'refs';
  63     *{ $pkg . '::' . $name } = $code;
  64 }
  65
  66 # copied from Class::Inspector
  67 sub get_method_list {
  68     my $self = shift;
  69     my $name = $self->name;
  70
  71     no strict 'refs';
  72     # Get all the CODE symbol table entries
  73     my @functions = grep !/^meta$/,
  74       grep { /\A[^\W\d]\w*\z/o }
  75       grep { defined &{"${name}::$_"} }
  76       keys %{"${name}::"};
  77     wantarray ? @functions : \@functions;
  78 }
  79
  80 sub add_attribute {
  81     my $self = shift;
  82     my $attr = shift;
  83
  84     $self->{'attributes'}{$attr->name} = $attr;
  85 }
  86
  87 sub compute_all_applicable_attributes {
  88     my $self = shift;
  89     my (@attr, %seen);
  90
  91     for my $class ($self->linearized_isa) {
  92         my $meta = $self->_metaclass_cache($class)
  93             or next;
  94
  95         for my $name (keys %{ $meta->get_attribute_map }) {
  96             next if $seen{$name}++;
  97             push @attr, $meta->get_attribute($name);
  98         }
  99     }
 100
 101     return @attr;
 102 }
 103
 104 sub get_attribute_map { $_[0]->{attributes} }
 105 sub has_attribute     { exists $_[0]->{attributes}->{$_[1]} }
 106 sub get_attribute     { $_[0]->{attributes}->{$_[1]} }
 107
 108 sub linearized_isa { @{ get_linear_isa($_[0]->name) } }
 109
 110 sub clone_object {
 111     my $class    = shift;
 112     my $instance = shift;
 113
 114     (blessed($instance) && $instance->isa($class->name))
 115         || confess "You must pass an instance of the metaclass (" . $class->name . "), not ($instance)";
 116
 117     $class->clone_instance($instance, @_);
 118 }
 119
 120 sub clone_instance {
 121     my ($class, $instance, %params) = @_;
 122
 123     (blessed($instance))
 124         || confess "You can only clone instances, ($instance) is not a blessed instance";
 125
 126     my $clone = bless { %$instance }, ref $instance;
 127
 128     foreach my $attr ($class->compute_all_applicable_attributes()) {
 129         if ( defined( my $init_arg = $attr->init_arg ) ) {
 130             if (exists $params{$init_arg}) {
 131                 $clone->{ $attr->name } = $params{$init_arg};
 132             }
 133         }
 134     }
 135
 136     return $clone;
 137
 138 }
 139
 140 sub make_immutable {}
 141 sub is_immutable { 0 }
 142
 143 sub attribute_metaclass { "Mouse::Meta::Class" }
 144
 145 sub add_before_method_modifier {
 146     my ($self, $name, $code) = @_;
 147     require Class::Method::Modifiers;
 148     Class::Method::Modifiers::_install_modifier(
 149         $self->name,
 150         'before',
 151         $name,
 152         $code,
 153     );
 154 }
 155
 156 sub add_around_method_modifier {
 157     my ($self, $name, $code) = @_;
 158     require Class::Method::Modifiers;
 159     Class::Method::Modifiers::_install_modifier(
 160         $self->name,
 161         'around',
 162         $name,
 163         $code,
 164     );
 165 }
 166
 167 sub add_after_method_modifier {
 168     my ($self, $name, $code) = @_;
 169     require Class::Method::Modifiers;
 170     Class::Method::Modifiers::_install_modifier(
 171         $self->name,
 172         'after',
 173         $name,
 174         $code,
 175     );
 176 }
 177
 178 1;
 179
 180 __END__
 181
 182 =head1 NAME
 183
 184 Mouse::Meta::Class - hook into the Mouse MOP
 185
 186 =head1 METHODS
 187
 188 =head2 initialize ClassName -> Mouse::Meta::Class
 189
 190 Finds or creates a Mouse::Meta::Class instance for the given ClassName. Only
 191 one instance should exist for a given class.
 192
 193 =head2 new %args -> Mouse::Meta::Class
 194
 195 Creates a new Mouse::Meta::Class. Don't call this directly.
 196
 197 =head2 name -> ClassName
 198
 199 Returns the name of the owner class.
 200
 201 =head2 superclasses -> [ClassName]
 202
 203 Gets (or sets) the list of superclasses of the owner class.
 204
 205 =head2 add_attribute Mouse::Meta::Attribute
 206
 207 Begins keeping track of the existing L<Mouse::Meta::Attribute> for the owner
 208 class.
 209
 210 =head2 compute_all_applicable_attributes -> (Mouse::Meta::Attribute)
 211
 212 Returns the list of all L<Mouse::Meta::Attribute> instances associated with
 213 this class and its superclasses.
 214
 215 =head2 get_attribute_map -> { name => Mouse::Meta::Attribute }
 216
 217 Returns a mapping of attribute names to their corresponding
 218 L<Mouse::Meta::Attribute> objects.
 219
 220 =head2 has_attribute Name -> Boool
 221
 222 Returns whether we have a L<Mouse::Meta::Attribute> with the given name.
 223
 224 =head2 get_attribute Name -> Mouse::Meta::Attribute | undef
 225
 226 Returns the L<Mouse::Meta::Attribute> with the given name.
 227
 228 =head2 linearized_isa -> [ClassNames]
 229
 230 Returns the list of classes in method dispatch order, with duplicates removed.
 231
 232 =head2 clone_object Instance -> Instance
 233
 234 Clones the given C<Instance> which must be an instance governed by this
 235 metaclass.
 236
 237 =head2 clone_instance Instance, Parameters -> Instance
 238
 239 Clones the given C<Instance> and sets any additional parameters.
 240
 241 =cut
 242