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 $role (@{$self->roles}) {
  42         return 1 if $role->does_role($role_name);
  43     }
  44     return 0;
  45 }
  46
  47 sub new_object {
  48     my ($class, %params) = @_;
  49     my $self = $class->SUPER::new_object(%params);
  50     foreach my $attr ($class->compute_all_applicable_attributes()) {
  51         next unless $params{$attr->init_arg} && $attr->can('has_trigger') && $attr->has_trigger;
  52         $attr->trigger->($self, $params{$attr->init_arg}, $attr);
  53     }
  54     return $self;
  55 }
  56
  57 sub construct_instance {
  58     my ($class, %params) = @_;
  59     my $meta_instance = $class->get_meta_instance;
  60     # FIXME:
  61     # the code below is almost certainly incorrect
  62     # but this is foreign inheritence, so we might
  63     # have to kludge it in the end.
  64     my $instance = $params{'__INSTANCE__'} || $meta_instance->create_instance();
  65     foreach my $attr ($class->compute_all_applicable_attributes()) {
  66         $attr->initialize_instance_slot($meta_instance, $instance, \%params)
  67     }
  68     return $instance;
  69 }
  70
  71 sub has_method {
  72     my ($self, $method_name) = @_;
  73     (defined $method_name && $method_name)
  74         || confess "You must define a method name";
  75
  76     my $sub_name = ($self->name . '::' . $method_name);
  77
  78     no strict 'refs';
  79     return 0 if !defined(&{$sub_name});
  80         my $method = \&{$sub_name};
  81
  82         return 1 if blessed($method) && $method->isa('Moose::Meta::Role::Method');
  83     return $self->SUPER::has_method($method_name);
  84 }
  85
  86 sub add_override_method_modifier {
  87     my ($self, $name, $method, $_super_package) = @_;
  88     (!$self->has_method($name))
  89         || confess "Cannot add an override method if a local method is already present";
  90     # need this for roles ...
  91     $_super_package ||= $self->name;
  92     my $super = $self->find_next_method_by_name($name);
  93     (defined $super)
  94         || confess "You cannot override '$name' because it has no super method";
  95     $self->add_method($name => bless sub {
  96         my @args = @_;
  97         no strict   'refs';
  98         no warnings 'redefine';
  99         local *{$_super_package . '::super'} = sub { $super->(@args) };
 100         return $method->(@args);
 101     } => 'Moose::Meta::Method::Overriden');
 102 }
 103
 104 sub add_augment_method_modifier {
 105     my ($self, $name, $method) = @_;
 106     (!$self->has_method($name))
 107         || confess "Cannot add an augment method if a local method is already present";
 108     my $super = $self->find_next_method_by_name($name);
 109     (defined $super)
 110         || confess "You cannot augment '$name' because it has no super method";
 111     my $_super_package = $super->package_name;
 112     # BUT!,... if this is an overriden method ....
 113     if ($super->isa('Moose::Meta::Method::Overriden')) {
 114         # we need to be sure that we actually
 115         # find the next method, which is not
 116         # an 'override' method, the reason is
 117         # that an 'override' method will not
 118         # be the one calling inner()
 119         my $real_super = $self->_find_next_method_by_name_which_is_not_overridden($name);
 120         $_super_package = $real_super->package_name;
 121     }
 122     $self->add_method($name => sub {
 123         my @args = @_;
 124         no strict   'refs';
 125         no warnings 'redefine';
 126         local *{$_super_package . '::inner'} = sub { $method->(@args) };
 127         return $super->(@args);
 128     });
 129 }
 130
 131 sub _find_next_method_by_name_which_is_not_overridden {
 132     my ($self, $name) = @_;
 133     my @methods = $self->find_all_methods_by_name($name);
 134     foreach my $method (@methods) {
 135         return $method->{code}
 136             if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
 137     }
 138     return undef;
 139 }
 140
 141 package Moose::Meta::Method::Overriden;
 142
 143 use strict;
 144 use warnings;
 145
 146 our $VERSION = '0.01';
 147
 148 use base 'Class::MOP::Method';
 149
 150 1;
 151
 152 __END__
 153
 154 =pod
 155
 156 =head1 NAME
 157
 158 Moose::Meta::Class - The Moose metaclass
 159
 160 =head1 DESCRIPTION
 161
 162 This is a subclass of L<Class::MOP::Class> with Moose specific
 163 extensions.
 164
 165 For the most part, the only time you will ever encounter an
 166 instance of this class is if you are doing some serious deep
 167 introspection. To really understand this class, you need to refer
 168 to the L<Class::MOP::Class> documentation.
 169
 170 =head1 METHODS
 171
 172 =over 4
 173
 174 =item B<initialize>
 175
 176 =item B<new_object>
 177
 178 We override this method to support the C<trigger> attribute option.
 179
 180 =item B<construct_instance>
 181
 182 This provides some Moose specific extensions to this method, you
 183 almost never call this method directly unless you really know what
 184 you are doing.
 185
 186 This method makes sure to handle the moose weak-ref, type-constraint
 187 and type coercion features.
 188
 189 =item B<has_method ($name)>
 190
 191 This accomidates Moose::Meta::Role::Method instances, which are
 192 aliased, instead of added, but still need to be counted as valid
 193 methods.
 194
 195 =item B<add_override_method_modifier ($name, $method)>
 196
 197 This will create an C<override> method modifier for you, and install
 198 it in the package.
 199
 200 =item B<add_augment_method_modifier ($name, $method)>
 201
 202 This will create an C<augment> method modifier for you, and install
 203 it in the package.
 204
 205 =item B<roles>
 206
 207 This will return an array of C<Moose::Meta::Role> instances which are
 208 attached to this class.
 209
 210 =item B<add_role ($role)>
 211
 212 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
 213 to the list of associated roles.
 214
 215 =item B<does_role ($role_name)>
 216
 217 This will test if this class C<does> a given C<$role_name>. It will
 218 not only check it's local roles, but ask them as well in order to
 219 cascade down the role hierarchy.
 220
 221 =item B<add_attribute $attr_name, %params>
 222
 223 This method does the same thing as L<Class::MOP::Class/add_attribute>, but adds
 224 suport for delegation.
 225
 226 =back
 227
 228 =head1 INTERNAL METHODS
 229
 230 =over 4
 231
 232 =item compute_delegation
 233
 234 =item generate_delegation_list
 235
 236 =item generate_delgate_method
 237
 238 =item get_delegatable_methods
 239
 240 =item filter_delegations
 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
 264