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.06';
  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         foreach my $role (@{$class->meta->roles}) {
  43             return 1 if $role->does_role($role_name);
  44         }
  45     }
  46     return 0;
  47 }
  48
  49 sub excludes_role {
  50     my ($self, $role_name) = @_;
  51     (defined $role_name)
  52         || confess "You must supply a role name to look for";
  53     foreach my $class ($self->class_precedence_list) {
  54         foreach my $role (@{$class->meta->roles}) {
  55             return 1 if $role->excludes_role($role_name);
  56         }
  57     }
  58     return 0;
  59 }
  60
  61 sub new_object {
  62     my ($class, %params) = @_;
  63     my $self = $class->SUPER::new_object(%params);
  64     foreach my $attr ($class->compute_all_applicable_attributes()) {
  65         next unless $params{$attr->init_arg} && $attr->can('has_trigger') && $attr->has_trigger;
  66         $attr->trigger->($self, $params{$attr->init_arg}, $attr);
  67     }
  68     return $self;
  69 }
  70
  71 sub construct_instance {
  72     my ($class, %params) = @_;
  73     my $meta_instance = $class->get_meta_instance;
  74     # FIXME:
  75     # the code below is almost certainly incorrect
  76     # but this is foreign inheritence, so we might
  77     # have to kludge it in the end.
  78     my $instance = $params{'__INSTANCE__'} || $meta_instance->create_instance();
  79     foreach my $attr ($class->compute_all_applicable_attributes()) {
  80         $attr->initialize_instance_slot($meta_instance, $instance, \%params)
  81     }
  82     return $instance;
  83 }
  84
  85 sub has_method {
  86     my ($self, $method_name) = @_;
  87     (defined $method_name && $method_name)
  88         || confess "You must define a method name";
  89
  90     my $sub_name = ($self->name . '::' . $method_name);
  91
  92     no strict 'refs';
  93     return 0 if !defined(&{$sub_name});
  94         my $method = \&{$sub_name};
  95
  96         return 1 if blessed($method) && $method->isa('Moose::Meta::Role::Method');
  97     return $self->SUPER::has_method($method_name);
  98 }
  99
 100 sub add_attribute {
 101     my $self = shift;
 102     my $name = shift;
 103     if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
 104         # NOTE:
 105         # if it is a HASH ref, we de-ref it.
 106         # this will usually mean that it is
 107         # coming from a role
 108         $self->SUPER::add_attribute($name => %{$_[0]});
 109     }
 110     else {
 111         # otherwise we just pass the args
 112         $self->SUPER::add_attribute($name => @_);
 113     }
 114 }
 115
 116 sub add_override_method_modifier {
 117     my ($self, $name, $method, $_super_package) = @_;
 118     (!$self->has_method($name))
 119         || confess "Cannot add an override method if a local method is already present";
 120     # need this for roles ...
 121     $_super_package ||= $self->name;
 122     my $super = $self->find_next_method_by_name($name);
 123     (defined $super)
 124         || confess "You cannot override '$name' because it has no super method";
 125     $self->add_method($name => bless sub {
 126         my @args = @_;
 127         no strict   'refs';
 128         no warnings 'redefine';
 129         local *{$_super_package . '::super'} = sub { $super->(@args) };
 130         return $method->(@args);
 131     } => 'Moose::Meta::Method::Overriden');
 132 }
 133
 134 sub add_augment_method_modifier {
 135     my ($self, $name, $method) = @_;
 136     (!$self->has_method($name))
 137         || confess "Cannot add an augment method if a local method is already present";
 138     my $super = $self->find_next_method_by_name($name);
 139     (defined $super)
 140         || confess "You cannot augment '$name' because it has no super method";
 141     my $_super_package = $super->package_name;
 142     # BUT!,... if this is an overriden method ....
 143     if ($super->isa('Moose::Meta::Method::Overriden')) {
 144         # we need to be sure that we actually
 145         # find the next method, which is not
 146         # an 'override' method, the reason is
 147         # that an 'override' method will not
 148         # be the one calling inner()
 149         my $real_super = $self->_find_next_method_by_name_which_is_not_overridden($name);
 150         $_super_package = $real_super->package_name;
 151     }
 152     $self->add_method($name => sub {
 153         my @args = @_;
 154         no strict   'refs';
 155         no warnings 'redefine';
 156         local *{$_super_package . '::inner'} = sub { $method->(@args) };
 157         return $super->(@args);
 158     });
 159 }
 160
 161 sub _find_next_method_by_name_which_is_not_overridden {
 162     my ($self, $name) = @_;
 163     my @methods = $self->find_all_methods_by_name($name);
 164     foreach my $method (@methods) {
 165         return $method->{code}
 166             if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
 167     }
 168     return undef;
 169 }
 170
 171 package Moose::Meta::Method::Overriden;
 172
 173 use strict;
 174 use warnings;
 175
 176 our $VERSION = '0.01';
 177
 178 use base 'Class::MOP::Method';
 179
 180 1;
 181
 182 __END__
 183
 184 =pod
 185
 186 =head1 NAME
 187
 188 Moose::Meta::Class - The Moose metaclass
 189
 190 =head1 DESCRIPTION
 191
 192 This is a subclass of L<Class::MOP::Class> with Moose specific
 193 extensions.
 194
 195 For the most part, the only time you will ever encounter an
 196 instance of this class is if you are doing some serious deep
 197 introspection. To really understand this class, you need to refer
 198 to the L<Class::MOP::Class> documentation.
 199
 200 =head1 METHODS
 201
 202 =over 4
 203
 204 =item B<initialize>
 205
 206 =item B<new_object>
 207
 208 We override this method to support the C<trigger> attribute option.
 209
 210 =item B<construct_instance>
 211
 212 This provides some Moose specific extensions to this method, you
 213 almost never call this method directly unless you really know what
 214 you are doing.
 215
 216 This method makes sure to handle the moose weak-ref, type-constraint
 217 and type coercion features.
 218
 219 =item B<has_method ($name)>
 220
 221 This accomidates Moose::Meta::Role::Method instances, which are
 222 aliased, instead of added, but still need to be counted as valid
 223 methods.
 224
 225 =item B<add_override_method_modifier ($name, $method)>
 226
 227 This will create an C<override> method modifier for you, and install
 228 it in the package.
 229
 230 =item B<add_augment_method_modifier ($name, $method)>
 231
 232 This will create an C<augment> method modifier for you, and install
 233 it in the package.
 234
 235 =item B<roles>
 236
 237 This will return an array of C<Moose::Meta::Role> instances which are
 238 attached to this class.
 239
 240 =item B<add_role ($role)>
 241
 242 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
 243 to the list of associated roles.
 244
 245 =item B<does_role ($role_name)>
 246
 247 This will test if this class C<does> a given C<$role_name>. It will
 248 not only check it's local roles, but ask them as well in order to
 249 cascade down the role hierarchy.
 250
 251 =item B<excludes_role ($role_name)>
 252
 253 This will test if this class C<excludes> a given C<$role_name>. It will
 254 not only check it's local roles, but ask them as well in order to
 255 cascade down the role hierarchy.
 256
 257 =item B<add_attribute $attr_name, %params>
 258
 259 This method does the same thing as L<Class::MOP::Class/add_attribute>, but adds
 260 suport for delegation.
 261
 262 =back
 263
 264 =head1 INTERNAL METHODS
 265
 266 =over 4
 267
 268 =item compute_delegation
 269
 270 =item generate_delegation_list
 271
 272 =item generate_delgate_method
 273
 274 =item get_delegatable_methods
 275
 276 =item filter_delegations
 277
 278 =back
 279
 280 =head1 BUGS
 281
 282 All complex software has bugs lurking in it, and this module is no
 283 exception. If you find a bug please either email me, or add the bug
 284 to cpan-RT.
 285
 286 =head1 AUTHOR
 287
 288 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 289
 290 =head1 COPYRIGHT AND LICENSE
 291
 292 Copyright 2006 by Infinity Interactive, Inc.
 293
 294 L<http://www.iinteractive.com>
 295
 296 This library is free software; you can redistribute it and/or modify
 297 it under the same terms as Perl itself.
 298
 299 =cut
 300