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