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