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::Meta::Method::Constructor;
   7 use Mouse::Meta::Method::Destructor;
   8 use Mouse::Util qw/get_linear_isa blessed/;
   9 use Carp 'confess';
  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 # copied from Class::Inspector
  69 sub get_method_list {
  70     my $self = shift;
  71     my $name = $self->name;
  72
  73     no strict 'refs';
  74     # Get all the CODE symbol table entries
  75     my @functions = grep !/^meta$/,
  76       grep { /\A[^\W\d]\w*\z/o }
  77       grep { defined &{"${name}::$_"} }
  78       keys %{"${name}::"};
  79     wantarray ? @functions : \@functions;
  80 }
  81
  82 sub add_attribute {
  83     my $self = shift;
  84     my $attr = shift;
  85
  86     $self->{'attributes'}{$attr->name} = $attr;
  87 }
  88
  89 sub compute_all_applicable_attributes {
  90     my $self = shift;
  91     my (@attr, %seen);
  92
  93     for my $class ($self->linearized_isa) {
  94         my $meta = $self->_metaclass_cache($class)
  95             or next;
  96
  97         for my $name (keys %{ $meta->get_attribute_map }) {
  98             next if $seen{$name}++;
  99             push @attr, $meta->get_attribute($name);
 100         }
 101     }
 102
 103     return @attr;
 104 }
 105
 106 sub get_attribute_map { $_[0]->{attributes} }
 107 sub has_attribute     { exists $_[0]->{attributes}->{$_[1]} }
 108 sub get_attribute     { $_[0]->{attributes}->{$_[1]} }
 109
 110 sub linearized_isa { @{ get_linear_isa($_[0]->name) } }
 111
 112 sub clone_object {
 113     my $class    = shift;
 114     my $instance = shift;
 115
 116     (blessed($instance) && $instance->isa($class->name))
 117         || confess "You must pass an instance of the metaclass (" . $class->name . "), not ($instance)";
 118
 119     $class->clone_instance($instance, @_);
 120 }
 121
 122 sub clone_instance {
 123     my ($class, $instance, %params) = @_;
 124
 125     (blessed($instance))
 126         || confess "You can only clone instances, ($instance) is not a blessed instance";
 127
 128     my $clone = bless { %$instance }, ref $instance;
 129
 130     foreach my $attr ($class->compute_all_applicable_attributes()) {
 131         if ( defined( my $init_arg = $attr->init_arg ) ) {
 132             if (exists $params{$init_arg}) {
 133                 $clone->{ $attr->name } = $params{$init_arg};
 134             }
 135         }
 136     }
 137
 138     return $clone;
 139
 140 }
 141
 142 sub make_immutable {
 143     my $self = shift;
 144     my $name = $self->name;
 145     $self->{is_immutable}++;
 146     no strict 'refs';
 147     *{"$name\::new"}     = Mouse::Meta::Method::Constructor->generate_constructor_method_inline( $self );
 148     *{"$name\::DESTROY"} = Mouse::Meta::Method::Destructor->generate_destructor_method_inline( $self );
 149 }
 150 sub make_mutable {
 151     Carp::croak "Mouse::Meta::Class->make_mutable does not supported by Mouse";
 152 }
 153 sub is_immutable { $_[0]->{is_immutable} }
 154
 155 sub attribute_metaclass { "Mouse::Meta::Class" }
 156
 157 sub add_before_method_modifier {
 158     my ($self, $name, $code) = @_;
 159     require Class::Method::Modifiers;
 160     Class::Method::Modifiers::_install_modifier(
 161         $self->name,
 162         'before',
 163         $name,
 164         $code,
 165     );
 166 }
 167
 168 sub add_around_method_modifier {
 169     my ($self, $name, $code) = @_;
 170     require Class::Method::Modifiers;
 171     Class::Method::Modifiers::_install_modifier(
 172         $self->name,
 173         'around',
 174         $name,
 175         $code,
 176     );
 177 }
 178
 179 sub add_after_method_modifier {
 180     my ($self, $name, $code) = @_;
 181     require Class::Method::Modifiers;
 182     Class::Method::Modifiers::_install_modifier(
 183         $self->name,
 184         'after',
 185         $name,
 186         $code,
 187     );
 188 }
 189
 190 1;
 191
 192 __END__
 193
 194 =head1 NAME
 195
 196 Mouse::Meta::Class - hook into the Mouse MOP
 197
 198 =head1 METHODS
 199
 200 =head2 initialize ClassName -> Mouse::Meta::Class
 201
 202 Finds or creates a Mouse::Meta::Class instance for the given ClassName. Only
 203 one instance should exist for a given class.
 204
 205 =head2 new %args -> Mouse::Meta::Class
 206
 207 Creates a new Mouse::Meta::Class. Don't call this directly.
 208
 209 =head2 name -> ClassName
 210
 211 Returns the name of the owner class.
 212
 213 =head2 superclasses -> [ClassName]
 214
 215 Gets (or sets) the list of superclasses of the owner class.
 216
 217 =head2 add_attribute Mouse::Meta::Attribute
 218
 219 Begins keeping track of the existing L<Mouse::Meta::Attribute> for the owner
 220 class.
 221
 222 =head2 compute_all_applicable_attributes -> (Mouse::Meta::Attribute)
 223
 224 Returns the list of all L<Mouse::Meta::Attribute> instances associated with
 225 this class and its superclasses.
 226
 227 =head2 get_attribute_map -> { name => Mouse::Meta::Attribute }
 228
 229 Returns a mapping of attribute names to their corresponding
 230 L<Mouse::Meta::Attribute> objects.
 231
 232 =head2 has_attribute Name -> Boool
 233
 234 Returns whether we have a L<Mouse::Meta::Attribute> with the given name.
 235
 236 =head2 get_attribute Name -> Mouse::Meta::Attribute | undef
 237
 238 Returns the L<Mouse::Meta::Attribute> with the given name.
 239
 240 =head2 linearized_isa -> [ClassNames]
 241
 242 Returns the list of classes in method dispatch order, with duplicates removed.
 243
 244 =head2 clone_object Instance -> Instance
 245
 246 Clones the given C<Instance> which must be an instance governed by this
 247 metaclass.
 248
 249 =head2 clone_instance Instance, Parameters -> Instance
 250
 251 Clones the given C<Instance> and sets any additional parameters.
 252
 253 =cut
 254