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';
  11
  12 our $VERSION = '0.05';
  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         @_);
  27 }
  28
  29 sub add_role {
  30     my ($self, $role) = @_;
  31     (blessed($role) && $role->isa('Moose::Meta::Role'))
  32         || confess "Roles must be instances of Moose::Meta::Role";
  33     push @{$self->roles} => $role;
  34 }
  35
  36 sub does_role {
  37     my ($self, $role_name) = @_;
  38     (defined $role_name)
  39         || confess "You must supply a role name to look for";
  40     foreach my $role (@{$self->roles}) {
  41         return 1 if $role->does_role($role_name);
  42     }
  43     return 0;
  44 }
  45
  46 sub new_object {
  47     my ($class, %params) = @_;
  48     my $self = $class->SUPER::new_object(%params);
  49     foreach my $attr ($class->compute_all_applicable_attributes()) {
  50         next unless $params{$attr->name} && $attr->has_trigger;
  51         $attr->trigger->($self, $params{$attr->name});
  52     }
  53     return $self;
  54 }
  55
  56 sub construct_instance {
  57     my ($class, %params) = @_;
  58     my $instance = $params{'__INSTANCE__'} || {};
  59     foreach my $attr ($class->compute_all_applicable_attributes()) {
  60         my $init_arg = $attr->init_arg();
  61         # try to fetch the init arg from the %params ...
  62         my $val;
  63         if (exists $params{$init_arg}) {
  64             $val = $params{$init_arg};
  65         }
  66         else {
  67             # skip it if it's lazy
  68             next if $attr->is_lazy;
  69             # and die if it's required and doesn't have a default value
  70             confess "Attribute (" . $attr->name . ") is required"
  71                 if $attr->is_required && !$attr->has_default;
  72         }
  73         # if nothing was in the %params, we can use the
  74         # attribute's default value (if it has one)
  75         if (!defined $val && $attr->has_default) {
  76             $val = $attr->default($instance);
  77         }
  78                 if (defined $val) {
  79                     if ($attr->has_type_constraint) {
  80                     if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
  81                         $val = $attr->type_constraint->coercion->coerce($val);
  82                     }
  83                 (defined($attr->type_constraint->check($val)))
  84                     || confess "Attribute (" . $attr->name . ") does not pass the type contraint with '$val'";
  85             }
  86                 }
  87         $instance->{$attr->name} = $val;
  88         if (defined $val && $attr->is_weak_ref) {
  89             weaken($instance->{$attr->name});
  90         }
  91     }
  92     return $instance;
  93 }
  94
  95 sub has_method {
  96     my ($self, $method_name) = @_;
  97     (defined $method_name && $method_name)
  98         || confess "You must define a method name";
  99
 100     my $sub_name = ($self->name . '::' . $method_name);
 101
 102     no strict 'refs';
 103     return 0 if !defined(&{$sub_name});
 104         my $method = \&{$sub_name};
 105
 106         return 1 if blessed($method) && $method->isa('Moose::Meta::Role::Method');
 107     return $self->SUPER::has_method($method_name);
 108 }
 109
 110
 111 sub add_override_method_modifier {
 112     my ($self, $name, $method, $_super_package) = @_;
 113     # need this for roles ...
 114     $_super_package ||= $self->name;
 115     my $super = $self->find_next_method_by_name($name);
 116     (defined $super)
 117         || confess "You cannot override '$name' because it has no super method";
 118     $self->add_method($name => bless sub {
 119         my @args = @_;
 120         no strict   'refs';
 121         no warnings 'redefine';
 122         local *{$_super_package . '::super'} = sub { $super->(@args) };
 123         return $method->(@args);
 124     } => 'Moose::Meta::Method::Overriden');
 125 }
 126
 127 sub add_augment_method_modifier {
 128     my ($self, $name, $method) = @_;
 129     my $super = $self->find_next_method_by_name($name);
 130     (defined $super)
 131         || confess "You cannot augment '$name' because it has no super method";
 132     my $_super_package = $super->package_name;
 133     # BUT!,... if this is an overriden method ....
 134     if ($super->isa('Moose::Meta::Method::Overriden')) {
 135         # we need to be sure that we actually
 136         # find the next method, which is not
 137         # an 'override' method, the reason is
 138         # that an 'override' method will not
 139         # be the one calling inner()
 140         my $real_super = $self->_find_next_method_by_name_which_is_not_overridden($name);
 141         $_super_package = $real_super->package_name;
 142     }
 143     $self->add_method($name => sub {
 144         my @args = @_;
 145         no strict   'refs';
 146         no warnings 'redefine';
 147         local *{$_super_package . '::inner'} = sub { $method->(@args) };
 148         return $super->(@args);
 149     });
 150 }
 151
 152 sub _find_next_method_by_name_which_is_not_overridden {
 153     my ($self, $name) = @_;
 154     my @methods = $self->find_all_methods_by_name($name);
 155     foreach my $method (@methods) {
 156         return $method->{code}
 157             if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
 158     }
 159     return undef;
 160 }
 161
 162 package Moose::Meta::Method::Overriden;
 163
 164 use strict;
 165 use warnings;
 166
 167 our $VERSION = '0.01';
 168
 169 use base 'Class::MOP::Method';
 170
 171 1;
 172
 173 __END__
 174
 175 =pod
 176
 177 =head1 NAME
 178
 179 Moose::Meta::Class - The Moose metaclass
 180
 181 =head1 DESCRIPTION
 182
 183 This is a subclass of L<Class::MOP::Class> with Moose specific
 184 extensions.
 185
 186 For the most part, the only time you will ever encounter an
 187 instance of this class is if you are doing some serious deep
 188 introspection. To really understand this class, you need to refer
 189 to the L<Class::MOP::Class> documentation.
 190
 191 =head1 METHODS
 192
 193 =over 4
 194
 195 =item B<initialize>
 196
 197 =item B<new_object>
 198
 199 We override this method to support the C<trigger> attribute option.
 200
 201 =item B<construct_instance>
 202
 203 This provides some Moose specific extensions to this method, you
 204 almost never call this method directly unless you really know what
 205 you are doing.
 206
 207 This method makes sure to handle the moose weak-ref, type-constraint
 208 and type coercion features.
 209
 210 =item B<has_method ($name)>
 211
 212 This accomidates Moose::Meta::Role::Method instances, which are
 213 aliased, instead of added, but still need to be counted as valid
 214 methods.
 215
 216 =item B<add_override_method_modifier ($name, $method)>
 217
 218 This will create an C<override> method modifier for you, and install
 219 it in the package.
 220
 221 =item B<add_augment_method_modifier ($name, $method)>
 222
 223 This will create an C<augment> method modifier for you, and install
 224 it in the package.
 225
 226 =item B<roles>
 227
 228 This will return an array of C<Moose::Meta::Role> instances which are
 229 attached to this class.
 230
 231 =item B<add_role ($role)>
 232
 233 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
 234 to the list of associated roles.
 235
 236 =item B<does_role ($role_name)>
 237
 238 This will test if this class C<does> a given C<$role_name>. It will
 239 not only check it's local roles, but ask them as well in order to
 240 cascade down the role hierarchy.
 241
 242 =back
 243
 244 =head1 BUGS
 245
 246 All complex software has bugs lurking in it, and this module is no
 247 exception. If you find a bug please either email me, or add the bug
 248 to cpan-RT.
 249
 250 =head1 AUTHOR
 251
 252 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 253
 254 =head1 COPYRIGHT AND LICENSE
 255
 256 Copyright 2006 by Infinity Interactive, Inc.
 257
 258 L<http://www.iinteractive.com>
 259
 260 This library is free software; you can redistribute it and/or modify
 261 it under the same terms as Perl itself.
 262
 263 =cut