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         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 sub _find_next_method_by_name_which_is_not_overridden {
 164     my ($self, $name) = @_;
 165     my @methods = $self->find_all_methods_by_name($name);
 166     foreach my $method (@methods) {
 167         return $method->{code}
 168             if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
 169     }
 170     return undef;
 171 }
 172
 173 package Moose::Meta::Method::Overriden;
 174
 175 use strict;
 176 use warnings;
 177
 178 our $VERSION = '0.01';
 179
 180 use base 'Class::MOP::Method';
 181
 182 1;
 183
 184 __END__
 185
 186 =pod
 187
 188 =head1 NAME
 189
 190 Moose::Meta::Class - The Moose metaclass
 191
 192 =head1 DESCRIPTION
 193
 194 This is a subclass of L<Class::MOP::Class> with Moose specific
 195 extensions.
 196
 197 For the most part, the only time you will ever encounter an
 198 instance of this class is if you are doing some serious deep
 199 introspection. To really understand this class, you need to refer
 200 to the L<Class::MOP::Class> documentation.
 201
 202 =head1 METHODS
 203
 204 =over 4
 205
 206 =item B<initialize>
 207
 208 =item B<new_object>
 209
 210 We override this method to support the C<trigger> attribute option.
 211
 212 =item B<construct_instance>
 213
 214 This provides some Moose specific extensions to this method, you
 215 almost never call this method directly unless you really know what
 216 you are doing.
 217
 218 This method makes sure to handle the moose weak-ref, type-constraint
 219 and type coercion features.
 220
 221 =item B<has_method ($name)>
 222
 223 This accomidates Moose::Meta::Role::Method instances, which are
 224 aliased, instead of added, but still need to be counted as valid
 225 methods.
 226
 227 =item B<add_override_method_modifier ($name, $method)>
 228
 229 This will create an C<override> method modifier for you, and install
 230 it in the package.
 231
 232 =item B<add_augment_method_modifier ($name, $method)>
 233
 234 This will create an C<augment> method modifier for you, and install
 235 it in the package.
 236
 237 =item B<roles>
 238
 239 This will return an array of C<Moose::Meta::Role> instances which are
 240 attached to this class.
 241
 242 =item B<add_role ($role)>
 243
 244 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
 245 to the list of associated roles.
 246
 247 =item B<does_role ($role_name)>
 248
 249 This will test if this class C<does> a given C<$role_name>. It will
 250 not only check it's local roles, but ask them as well in order to
 251 cascade down the role hierarchy.
 252
 253 =item B<excludes_role ($role_name)>
 254
 255 This will test if this class C<excludes> a given C<$role_name>. It will
 256 not only check it's local roles, but ask them as well in order to
 257 cascade down the role hierarchy.
 258
 259 =item B<add_attribute ($attr_name, %params|$params)>
 260
 261 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
 262 support for taking the C<$params> as a HASH ref.
 263
 264 =back
 265
 266 =head1 BUGS
 267
 268 All complex software has bugs lurking in it, and this module is no
 269 exception. If you find a bug please either email me, or add the bug
 270 to cpan-RT.
 271
 272 =head1 AUTHOR
 273
 274 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 275
 276 =head1 COPYRIGHT AND LICENSE
 277
 278 Copyright 2006 by Infinity Interactive, Inc.
 279
 280 L<http://www.iinteractive.com>
 281
 282 This library is free software; you can redistribute it and/or modify
 283 it under the same terms as Perl itself.
 284
 285 =cut
 286