lib/Mouse/Meta/Class.pm

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