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 =item B<construct_instance>
 190
 191 This provides some Moose specific extensions to this method, you
 192 almost never call this method directly unless you really know what
 193 you are doing.
 194
 195 This method makes sure to handle the moose weak-ref, type-constraint
 196 and type coercion features.
 197
 198 =item B<has_method ($name)>
 199
 200 This accomidates Moose::Meta::Role::Method instances, which are
 201 aliased, instead of added, but still need to be counted as valid
 202 methods.
 203
 204 =item B<add_override_method_modifier ($name, $method)>
 205
 206 =item B<add_augment_method_modifier ($name, $method)>
 207
 208 =item B<roles>
 209
 210 =item B<add_role ($role)>
 211
 212 =item B<does_role ($role_name)>
 213
 214 =back
 215
 216 =head1 BUGS
 217
 218 All complex software has bugs lurking in it, and this module is no
 219 exception. If you find a bug please either email me, or add the bug
 220 to cpan-RT.
 221
 222 =head1 AUTHOR
 223
 224 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 225
 226 =head1 COPYRIGHT AND LICENSE
 227
 228 Copyright 2006 by Infinity Interactive, Inc.
 229
 230 L<http://www.iinteractive.com>
 231
 232 This library is free software; you can redistribute it and/or modify
 233 it under the same terms as Perl itself.
 234
 235 =cut