lib/Mouse/Meta/Class.pm

   1 package Mouse::Meta::Class;
   2 use strict;
   3 use warnings;
   4
   5 use Mouse::Meta::Method::Constructor;
   6 use Mouse::Meta::Method::Destructor;
   7 use Scalar::Util qw/blessed weaken/;
   8 use Mouse::Util qw/get_linear_isa/;
   9 use Carp 'confess';
  10
  11 use base qw(Mouse::Meta::Module);
  12
  13 do {
  14     my %METACLASS_CACHE;
  15
  16     # because Mouse doesn't introspect existing classes, we're forced to
  17     # only pay attention to other Mouse classes
  18     sub _metaclass_cache {
  19         my $class = shift;
  20         my $name  = shift;
  21         return $METACLASS_CACHE{$name};
  22     }
  23
  24     sub initialize {
  25         my($class, $package_name, @args) = @_;
  26
  27         ($package_name && !ref($package_name))\r
  28             || confess("You must pass a package name and it cannot be blessed");\r
  29
  30         return $METACLASS_CACHE{$package_name}
  31             ||= $class->_construct_class_instance(package => $package_name, @args);
  32     }
  33
  34     sub class_of{
  35         my($class_or_instance) = @_;
  36         return undef unless defined $class_or_instance;
  37         return $METACLASS_CACHE{ blessed($class_or_instance) || $class_or_instance };
  38     }
  39
  40     # Means of accessing all the metaclasses that have
  41     # been initialized thus far
  42     sub get_all_metaclasses         {        %METACLASS_CACHE         }
  43     sub get_all_metaclass_instances { values %METACLASS_CACHE         }
  44     sub get_all_metaclass_names     { keys   %METACLASS_CACHE         }
  45     sub get_metaclass_by_name       { $METACLASS_CACHE{$_[0]}         }
  46     sub store_metaclass_by_name     { $METACLASS_CACHE{$_[0]} = $_[1] }
  47     sub weaken_metaclass            { weaken($METACLASS_CACHE{$_[0]}) }
  48     sub does_metaclass_exist        { exists $METACLASS_CACHE{$_[0]} && defined $METACLASS_CACHE{$_[0]} }
  49     sub remove_metaclass_by_name    { $METACLASS_CACHE{$_[0]} = undef }
  50 };
  51
  52 sub _construct_class_instance {
  53     my($class, %args) = @_;
  54
  55     $args{attributes}   = {};
  56     $args{superclasses} = do {
  57         no strict 'refs';
  58         \@{ $args{package} . '::ISA' };
  59     };
  60     $args{roles}   ||= [];
  61     $args{methods} ||= {};
  62
  63     bless \%args, $class;
  64 }
  65
  66 sub roles { $_[0]->{roles} }
  67
  68 sub superclasses {
  69     my $self = shift;
  70
  71     if (@_) {
  72         Mouse::load_class($_) for @_;
  73         @{ $self->{superclasses} } = @_;
  74     }
  75
  76     @{ $self->{superclasses} };
  77 }
  78
  79 sub get_all_method_names {
  80     my $self = shift;
  81     my %uniq;
  82     return grep { $uniq{$_}++ == 0 }
  83             map { Mouse::Meta::Class->initialize($_)->get_method_list() }
  84             $self->linearized_isa;
  85 }
  86
  87 sub add_attribute {
  88     my $self = shift;
  89
  90     if (@_ == 1 && blessed($_[0])) {
  91         my $attr = shift @_;
  92         $self->{'attributes'}{$attr->name} = $attr;
  93     } else {
  94         my $names = shift @_;
  95         $names = [$names] if !ref($names);
  96         my $metaclass = 'Mouse::Meta::Attribute';
  97         my %options = @_;
  98
  99         if ( my $metaclass_name = delete $options{metaclass} ) {
 100             my $new_class = Mouse::Util::resolve_metaclass_alias(
 101                 'Attribute',
 102                 $metaclass_name
 103             );
 104             if ( $metaclass ne $new_class ) {
 105                 $metaclass = $new_class;
 106             }
 107         }
 108
 109         for my $name (@$names) {
 110             if ($name =~ s/^\+//) {
 111                 $metaclass->clone_parent($self, $name, @_);
 112             }
 113             else {
 114                 $metaclass->create($self, $name, @_);
 115             }
 116         }
 117     }
 118 }
 119
 120 sub compute_all_applicable_attributes { shift->get_all_attributes(@_) }
 121 sub get_all_attributes {
 122     my $self = shift;
 123     my (@attr, %seen);
 124
 125     for my $class ($self->linearized_isa) {
 126         my $meta = $self->_metaclass_cache($class)
 127             or next;
 128
 129         for my $name (keys %{ $meta->get_attribute_map }) {
 130             next if $seen{$name}++;
 131             push @attr, $meta->get_attribute($name);
 132         }
 133     }
 134
 135     return @attr;
 136 }
 137
 138 sub get_attribute_map { $_[0]->{attributes} }
 139 sub has_attribute     { exists $_[0]->{attributes}->{$_[1]} }
 140 sub get_attribute     { $_[0]->{attributes}->{$_[1]} }
 141 sub get_attribute_list {
 142     my $self = shift;
 143     keys %{$self->get_attribute_map};
 144 }
 145
 146 sub linearized_isa { @{ get_linear_isa($_[0]->name) } }
 147
 148 sub clone_object {
 149     my $class    = shift;
 150     my $instance = shift;
 151
 152     (blessed($instance) && $instance->isa($class->name))
 153         || confess "You must pass an instance of the metaclass (" . $class->name . "), not ($instance)";
 154
 155     $class->clone_instance($instance, @_);
 156 }
 157
 158 sub clone_instance {
 159     my ($class, $instance, %params) = @_;
 160
 161     (blessed($instance))
 162         || confess "You can only clone instances, ($instance) is not a blessed instance";
 163
 164     my $clone = bless { %$instance }, ref $instance;
 165
 166     foreach my $attr ($class->get_all_attributes()) {
 167         if ( defined( my $init_arg = $attr->init_arg ) ) {
 168             if (exists $params{$init_arg}) {
 169                 $clone->{ $attr->name } = $params{$init_arg};
 170             }
 171         }
 172     }
 173
 174     return $clone;
 175
 176 }
 177
 178 sub make_immutable {
 179     my $self = shift;
 180     my %args = (
 181         inline_constructor => 1,
 182         inline_destructor  => 1,
 183         @_,
 184     );
 185
 186     my $name = $self->name;
 187     $self->{is_immutable}++;
 188
 189     if ($args{inline_constructor}) {
 190         $self->add_method('new' => Mouse::Meta::Method::Constructor->generate_constructor_method_inline( $self ));
 191     }
 192
 193     if ($args{inline_destructor}) {
 194         $self->add_method('DESTROY' => Mouse::Meta::Method::Destructor->generate_destructor_method_inline( $self ));
 195     }
 196
 197     # Moose's make_immutable returns true allowing calling code to skip setting an explicit true value
 198     # at the end of a source file.
 199     return 1;
 200 }
 201
 202 sub make_mutable { confess "Mouse does not currently support 'make_mutable'" }
 203
 204 sub is_immutable { $_[0]->{is_immutable} }
 205
 206 sub attribute_metaclass { "Mouse::Meta::Class" }
 207
 208 sub _install_modifier {
 209     my ( $self, $into, $type, $name, $code ) = @_;
 210
 211     # which is modifer class available?
 212     my $modifier_class = do {
 213         if (eval "require Class::Method::Modifiers::Fast; 1") {
 214             'Class::Method::Modifiers::Fast';
 215         } elsif (eval "require Class::Method::Modifiers; 1") {
 216             'Class::Method::Modifiers';
 217         } else {
 218             Carp::croak("Method modifiers require the use of Class::Method::Modifiers or Class::Method::Modifiers::Fast. Please install it from CPAN and file a bug report with this application.");
 219         }
 220     };
 221     my $modifier = $modifier_class->can('_install_modifier');
 222
 223     # replace this method itself :)
 224     {
 225         no strict 'refs';
 226         no warnings 'redefine';
 227         *{__PACKAGE__ . '::_install_modifier'} = sub {
 228             my ( $self, $into, $type, $name, $code ) = @_;
 229             $modifier->(
 230                 $into,
 231                 $type,
 232                 $name,
 233                 $code
 234             );
 235         };
 236     }
 237
 238     # call me. for first time.
 239     $self->_install_modifier( $into, $type, $name, $code );
 240 }
 241
 242 sub add_before_method_modifier {
 243     my ( $self, $name, $code ) = @_;
 244     $self->_install_modifier( $self->name, 'before', $name, $code );
 245 }
 246
 247 sub add_around_method_modifier {
 248     my ( $self, $name, $code ) = @_;
 249     $self->_install_modifier( $self->name, 'around', $name, $code );
 250 }
 251
 252 sub add_after_method_modifier {
 253     my ( $self, $name, $code ) = @_;
 254     $self->_install_modifier( $self->name, 'after', $name, $code );
 255 }
 256
 257 sub add_override_method_modifier {
 258     my ($self, $name, $code) = @_;
 259
 260     my $pkg = $self->name;
 261     my $method = "${pkg}::${name}";
 262
 263     # Class::Method::Modifiers won't do this for us, so do it ourselves
 264
 265     my $body = $pkg->can($name)
 266         or confess "You cannot override '$method' because it has no super method";
 267
 268     no strict 'refs';
 269     *$method = sub { $code->($pkg, $body, @_) };
 270 }
 271
 272 sub does_role {
 273     my ($self, $role_name) = @_;
 274
 275     (defined $role_name)
 276         || confess "You must supply a role name to look for";
 277
 278     for my $class ($self->linearized_isa) {
 279         my $meta = class_of($class);
 280         next unless $meta && $meta->can('roles');
 281
 282         for my $role (@{ $meta->roles }) {
 283             return 1 if $role->does_role($role_name);
 284         }
 285     }
 286
 287     return 0;
 288 }
 289
 290 sub create {
 291     my ($class, $package_name, %options) = @_;
 292
 293     (ref $options{superclasses} eq 'ARRAY')
 294         || confess "You must pass an ARRAY ref of superclasses"
 295             if exists $options{superclasses};
 296
 297     (ref $options{attributes} eq 'ARRAY')
 298         || confess "You must pass an ARRAY ref of attributes"
 299             if exists $options{attributes};
 300
 301     (ref $options{methods} eq 'HASH')
 302         || confess "You must pass a HASH ref of methods"
 303             if exists $options{methods};
 304
 305     do {
 306         ( defined $package_name && $package_name )
 307           || confess "You must pass a package name";
 308
 309         my $code = "package $package_name;";
 310         $code .= "\$$package_name\:\:VERSION = '" . $options{version} . "';"
 311           if exists $options{version};
 312         $code .= "\$$package_name\:\:AUTHORITY = '" . $options{authority} . "';"
 313           if exists $options{authority};
 314
 315         eval $code;
 316         confess "creation of $package_name failed : $@" if $@;
 317     };
 318
 319     my %initialize_options = %options;
 320     delete @initialize_options{qw(
 321         package
 322         superclasses
 323         attributes
 324         methods
 325         version
 326         authority
 327     )};
 328     my $meta = $class->initialize( $package_name => %initialize_options );
 329
 330     # FIXME totally lame
 331     $meta->add_method('meta' => sub {
 332         Mouse::Meta::Class->initialize(ref($_[0]) || $_[0]);
 333     });
 334
 335     $meta->superclasses(@{$options{superclasses}})
 336         if exists $options{superclasses};
 337     # NOTE:
 338     # process attributes first, so that they can
 339     # install accessors, but locally defined methods
 340     # can then overwrite them. It is maybe a little odd, but
 341     # I think this should be the order of things.
 342     if (exists $options{attributes}) {
 343         foreach my $attr (@{$options{attributes}}) {
 344             Mouse::Meta::Attribute->create($meta, $attr->{name}, %$attr);
 345         }
 346     }
 347     if (exists $options{methods}) {
 348         foreach my $method_name (keys %{$options{methods}}) {
 349             $meta->add_method($method_name, $options{methods}->{$method_name});
 350         }
 351     }
 352     return $meta;
 353 }
 354
 355 {
 356     my $ANON_CLASS_SERIAL = 0;
 357     my $ANON_CLASS_PREFIX = 'Mouse::Meta::Class::__ANON__::SERIAL::';
 358     sub create_anon_class {
 359         my ( $class, %options ) = @_;
 360         my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL;
 361         return $class->create( $package_name, %options );
 362     }
 363 }
 364
 365 1;
 366
 367 __END__
 368
 369 =head1 NAME
 370
 371 Mouse::Meta::Class - hook into the Mouse MOP
 372
 373 =head1 METHODS
 374
 375 =head2 initialize ClassName -> Mouse::Meta::Class
 376
 377 Finds or creates a Mouse::Meta::Class instance for the given ClassName. Only
 378 one instance should exist for a given class.
 379
 380 =head2 new %args -> Mouse::Meta::Class
 381
 382 Creates a new Mouse::Meta::Class. Don't call this directly.
 383
 384 =head2 name -> ClassName
 385
 386 Returns the name of the owner class.
 387
 388 =head2 superclasses -> [ClassName]
 389
 390 Gets (or sets) the list of superclasses of the owner class.
 391
 392 =head2 add_attribute (Mouse::Meta::Attribute| name => spec)
 393
 394 Begins keeping track of the existing L<Mouse::Meta::Attribute> for the owner
 395 class.
 396
 397 =head2 get_all_attributes -> (Mouse::Meta::Attribute)
 398
 399 Returns the list of all L<Mouse::Meta::Attribute> instances associated with
 400 this class and its superclasses.
 401
 402 =head2 get_attribute_map -> { name => Mouse::Meta::Attribute }
 403
 404 Returns a mapping of attribute names to their corresponding
 405 L<Mouse::Meta::Attribute> objects.
 406
 407 =head2 get_attribute_list -> { name => Mouse::Meta::Attribute }
 408
 409 This returns a list of attribute names which are defined in the local
 410 class. If you want a list of all applicable attributes for a class,
 411 use the C<get_all_attributes> method.
 412
 413 =head2 has_attribute Name -> Bool
 414
 415 Returns whether we have a L<Mouse::Meta::Attribute> with the given name.
 416
 417 =head2 get_attribute Name -> Mouse::Meta::Attribute | undef
 418
 419 Returns the L<Mouse::Meta::Attribute> with the given name.
 420
 421 =head2 linearized_isa -> [ClassNames]
 422
 423 Returns the list of classes in method dispatch order, with duplicates removed.
 424
 425 =head2 clone_object Instance -> Instance
 426
 427 Clones the given C<Instance> which must be an instance governed by this
 428 metaclass.
 429
 430 =head2 clone_instance Instance, Parameters -> Instance
 431
 432 The clone_instance method has been made private.
 433 The public version is deprecated.
 434
 435 =cut
 436