lib/Moose/Meta/Class.pm

   1
   2 package Moose::Meta::Class;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Class::MOP;
   8
   9 use Carp         'confess';
  10 use Scalar::Util 'weaken', 'blessed', 'reftype';
  11
  12 our $VERSION = '0.07';
  13
  14 use base 'Class::MOP::Class';
  15
  16 __PACKAGE__->meta->add_attribute('roles' => (
  17     reader  => 'roles',
  18     default => sub { [] }
  19 ));
  20
  21 sub initialize {
  22     my $class = shift;
  23     my $pkg   = shift;
  24     $class->SUPER::initialize($pkg,
  25         ':attribute_metaclass' => 'Moose::Meta::Attribute',
  26         ':instance_metaclass'  => 'Moose::Meta::Instance',
  27         @_);
  28 }
  29
  30 sub add_role {
  31     my ($self, $role) = @_;
  32     (blessed($role) && $role->isa('Moose::Meta::Role'))
  33         || confess "Roles must be instances of Moose::Meta::Role";
  34     push @{$self->roles} => $role;
  35 }
  36
  37 sub calculate_all_roles {
  38     my $self = shift;
  39     my %seen;
  40     grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
  41 }
  42
  43 sub does_role {
  44     my ($self, $role_name) = @_;
  45     (defined $role_name)
  46         || confess "You must supply a role name to look for";
  47     foreach my $class ($self->class_precedence_list) {
  48         next unless $class->can('meta');
  49         foreach my $role (@{$class->meta->roles}) {
  50             return 1 if $role->does_role($role_name);
  51         }
  52     }
  53     return 0;
  54 }
  55
  56 sub excludes_role {
  57     my ($self, $role_name) = @_;
  58     (defined $role_name)
  59         || confess "You must supply a role name to look for";
  60     foreach my $class ($self->class_precedence_list) {
  61         next unless $class->can('meta');
  62         foreach my $role (@{$class->meta->roles}) {
  63             return 1 if $role->excludes_role($role_name);
  64         }
  65     }
  66     return 0;
  67 }
  68
  69 sub new_object {
  70     my ($class, %params) = @_;
  71     my $self = $class->SUPER::new_object(%params);
  72     foreach my $attr ($class->compute_all_applicable_attributes()) {
  73         # FIXME:
  74         # this does not accept undefined
  75         # values, nor does it accept false
  76         # values to be passed into the init-arg
  77         next unless $params{$attr->init_arg} && $attr->can('has_trigger') && $attr->has_trigger;
  78         $attr->trigger->($self, $params{$attr->init_arg}, $attr);
  79     }
  80     return $self;
  81 }
  82
  83 sub construct_instance {
  84     my ($class, %params) = @_;
  85     my $meta_instance = $class->get_meta_instance;
  86     # FIXME:
  87     # the code below is almost certainly incorrect
  88     # but this is foreign inheritence, so we might
  89     # have to kludge it in the end.
  90     my $instance = $params{'__INSTANCE__'} || $meta_instance->create_instance();
  91     foreach my $attr ($class->compute_all_applicable_attributes()) {
  92         $attr->initialize_instance_slot($meta_instance, $instance, \%params)
  93     }
  94     return $instance;
  95 }
  96
  97 sub has_method {
  98     my ($self, $method_name) = @_;
  99     (defined $method_name && $method_name)
 100         || confess "You must define a method name";
 101
 102     my $sub_name = ($self->name . '::' . $method_name);
 103
 104     no strict 'refs';
 105     return 0 if !defined(&{$sub_name});
 106         my $method = \&{$sub_name};
 107
 108         return 1 if blessed($method) && $method->isa('Moose::Meta::Role::Method');
 109     return $self->SUPER::has_method($method_name);
 110 }
 111
 112 sub add_attribute {
 113     my $self = shift;
 114     my $name = shift;
 115     if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
 116         # NOTE:
 117         # if it is a HASH ref, we de-ref it.
 118         # this will usually mean that it is
 119         # coming from a role
 120         $self->SUPER::add_attribute($name => %{$_[0]});
 121     }
 122     else {
 123         # otherwise we just pass the args
 124         $self->SUPER::add_attribute($name => @_);
 125     }
 126 }
 127
 128 sub add_override_method_modifier {
 129     my ($self, $name, $method, $_super_package) = @_;
 130     (!$self->has_method($name))
 131         || confess "Cannot add an override method if a local method is already present";
 132     # need this for roles ...
 133     $_super_package ||= $self->name;
 134     my $super = $self->find_next_method_by_name($name);
 135     (defined $super)
 136         || confess "You cannot override '$name' because it has no super method";
 137     $self->add_method($name => bless sub {
 138         my @args = @_;
 139         no strict   'refs';
 140         no warnings 'redefine';
 141         local *{$_super_package . '::super'} = sub { $super->(@args) };
 142         return $method->(@args);
 143     } => 'Moose::Meta::Method::Overriden');
 144 }
 145
 146 sub add_augment_method_modifier {
 147     my ($self, $name, $method) = @_;
 148     (!$self->has_method($name))
 149         || confess "Cannot add an augment method if a local method is already present";
 150     my $super = $self->find_next_method_by_name($name);
 151     (defined $super)
 152         || confess "You cannot augment '$name' because it has no super method";
 153     my $_super_package = $super->package_name;
 154     # BUT!,... if this is an overriden method ....
 155     if ($super->isa('Moose::Meta::Method::Overriden')) {
 156         # we need to be sure that we actually
 157         # find the next method, which is not
 158         # an 'override' method, the reason is
 159         # that an 'override' method will not
 160         # be the one calling inner()
 161         my $real_super = $self->_find_next_method_by_name_which_is_not_overridden($name);
 162         $_super_package = $real_super->package_name;
 163     }
 164     $self->add_method($name => sub {
 165         my @args = @_;
 166         no strict   'refs';
 167         no warnings 'redefine';
 168         local *{$_super_package . '::inner'} = sub { $method->(@args) };
 169         return $super->(@args);
 170     });
 171 }
 172
 173 ## Private Utility methods ...
 174
 175 sub _find_next_method_by_name_which_is_not_overridden {
 176     my ($self, $name) = @_;
 177     my @methods = $self->find_all_methods_by_name($name);
 178     foreach my $method (@methods) {
 179         return $method->{code}
 180             if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
 181     }
 182     return undef;
 183 }
 184
 185 sub _fix_metaclass_incompatability {
 186     my ($self, @superclasses) = @_;
 187     foreach my $super (@superclasses) {
 188         # don't bother if it does not have a meta.
 189         next unless $super->can('meta');
 190         # if it's meta is a vanilla Moose,
 191         # then we can safely ignore it.
 192         next if blessed($super->meta) eq 'Moose::Meta::Class';
 193         # but if we have anything else,
 194         # we need to check it out ...
 195         unless (# see if of our metaclass is incompatible
 196                 ($self->isa(blessed($super->meta)) &&
 197                  # and see if our instance metaclass is incompatible
 198                  $self->instance_metaclass->isa($super->meta->instance_metaclass)) &&
 199                 # ... and if we are just a vanilla Moose
 200                 $self->isa('Moose::Meta::Class')) {
 201             # re-initialize the meta ...
 202             my $super_meta = $super->meta;
 203             # NOTE:
 204             # We might want to consider actually
 205             # transfering any attributes from the
 206             # original meta into this one, but in
 207             # general you should not have any there
 208             # at this point anyway, so it's very
 209             # much an obscure edge case anyway
 210             $self = $super_meta->reinitialize($self->name => (
 211                 ':attribute_metaclass' => $super_meta->attribute_metaclass,
 212                 ':method_metaclass'    => $super_meta->method_metaclass,
 213                 ':instance_metaclass'  => $super_meta->instance_metaclass,
 214             ));
 215         }
 216     }
 217     return $self;
 218 }
 219
 220 sub _apply_all_roles {
 221     my ($self, @roles) = @_;
 222     ($_->can('meta') && $_->meta->isa('Moose::Meta::Role'))
 223         || confess "You can only consume roles, $_ is not a Moose role"
 224             foreach @roles;
 225     if (scalar @roles == 1) {
 226         $roles[0]->meta->apply($self);
 227     }
 228     else {
 229         Moose::Meta::Role->combine(
 230             map { $_->meta } @roles
 231         )->apply($self);
 232     }
 233 }
 234
 235 sub _process_attribute {
 236     my ($self, $name, %options) = @_;
 237     if ($name =~ /^\+(.*)/) {
 238         my $new_attr = $self->_process_inherited_attribute($1, %options);
 239         $self->add_attribute($new_attr);
 240     }
 241     else {
 242         if ($options{metaclass}) {
 243             Moose::_load_all_classes($options{metaclass});
 244             $self->add_attribute($options{metaclass}->new($name, %options));
 245         }
 246         else {
 247             $self->add_attribute($name, %options);
 248         }
 249     }
 250 }
 251
 252 sub _process_inherited_attribute {
 253     my ($self, $attr_name, %options) = @_;
 254     my $inherited_attr = $self->find_attribute_by_name($attr_name);
 255     (defined $inherited_attr)
 256         || confess "Could not find an attribute by the name of '$attr_name' to inherit from";
 257     my $new_attr;
 258     if ($inherited_attr->isa('Moose::Meta::Attribute')) {
 259         $new_attr = $inherited_attr->clone_and_inherit_options(%options);
 260     }
 261     else {
 262         # NOTE:
 263         # kind of a kludge to handle Class::MOP::Attributes
 264         $new_attr = Moose::Meta::Attribute::clone_and_inherit_options(
 265             $inherited_attr, %options
 266         );
 267     }
 268     return $new_attr;
 269 }
 270
 271 package Moose::Meta::Method::Overriden;
 272
 273 use strict;
 274 use warnings;
 275
 276 our $VERSION = '0.01';
 277
 278 use base 'Class::MOP::Method';
 279
 280 1;
 281
 282 __END__
 283
 284 =pod
 285
 286 =head1 NAME
 287
 288 Moose::Meta::Class - The Moose metaclass
 289
 290 =head1 DESCRIPTION
 291
 292 This is a subclass of L<Class::MOP::Class> with Moose specific
 293 extensions.
 294
 295 For the most part, the only time you will ever encounter an
 296 instance of this class is if you are doing some serious deep
 297 introspection. To really understand this class, you need to refer
 298 to the L<Class::MOP::Class> documentation.
 299
 300 =head1 METHODS
 301
 302 =over 4
 303
 304 =item B<initialize>
 305
 306 =item B<new_object>
 307
 308 We override this method to support the C<trigger> attribute option.
 309
 310 =item B<construct_instance>
 311
 312 This provides some Moose specific extensions to this method, you
 313 almost never call this method directly unless you really know what
 314 you are doing.
 315
 316 This method makes sure to handle the moose weak-ref, type-constraint
 317 and type coercion features.
 318
 319 =item B<has_method ($name)>
 320
 321 This accomidates Moose::Meta::Role::Method instances, which are
 322 aliased, instead of added, but still need to be counted as valid
 323 methods.
 324
 325 =item B<add_override_method_modifier ($name, $method)>
 326
 327 This will create an C<override> method modifier for you, and install
 328 it in the package.
 329
 330 =item B<add_augment_method_modifier ($name, $method)>
 331
 332 This will create an C<augment> method modifier for you, and install
 333 it in the package.
 334
 335 =item B<roles>
 336
 337 This will return an array of C<Moose::Meta::Role> instances which are
 338 attached to this class.
 339
 340 =item B<add_role ($role)>
 341
 342 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
 343 to the list of associated roles.
 344
 345 =item B<does_role ($role_name)>
 346
 347 This will test if this class C<does> a given C<$role_name>. It will
 348 not only check it's local roles, but ask them as well in order to
 349 cascade down the role hierarchy.
 350
 351 =item B<excludes_role ($role_name)>
 352
 353 This will test if this class C<excludes> a given C<$role_name>. It will
 354 not only check it's local roles, but ask them as well in order to
 355 cascade down the role hierarchy.
 356
 357 =item B<add_attribute ($attr_name, %params|$params)>
 358
 359 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
 360 support for taking the C<$params> as a HASH ref.
 361
 362 =back
 363
 364 =head1 BUGS
 365
 366 All complex software has bugs lurking in it, and this module is no
 367 exception. If you find a bug please either email me, or add the bug
 368 to cpan-RT.
 369
 370 =head1 AUTHOR
 371
 372 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 373
 374 =head1 COPYRIGHT AND LICENSE
 375
 376 Copyright 2006 by Infinity Interactive, Inc.
 377
 378 L<http://www.iinteractive.com>
 379
 380 This library is free software; you can redistribute it and/or modify
 381 it under the same terms as Perl itself.
 382
 383 =cut
 384