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