2 package Moose::Meta::Class;
10 use Scalar::Util 'weaken', 'blessed', 'reftype';
12 our $VERSION = '0.08';
14 use Moose::Meta::Method::Overriden;
16 use base 'Class::MOP::Class';
18 __PACKAGE__->meta->add_attribute('roles' => (
26 $class->SUPER::initialize($pkg,
27 'attribute_metaclass' => 'Moose::Meta::Attribute',
28 'method_metaclass' => 'Moose::Meta::Method',
29 'instance_metaclass' => 'Moose::Meta::Instance',
34 my ($self, $role) = @_;
35 (blessed($role) && $role->isa('Moose::Meta::Role'))
36 || confess "Roles must be instances of Moose::Meta::Role";
37 push @{$self->roles} => $role;
40 sub calculate_all_roles {
43 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
47 my ($self, $role_name) = @_;
49 || confess "You must supply a role name to look for";
50 foreach my $class ($self->class_precedence_list) {
51 next unless $class->can('meta');
52 foreach my $role (@{$class->meta->roles}) {
53 return 1 if $role->does_role($role_name);
60 my ($self, $role_name) = @_;
62 || confess "You must supply a role name to look for";
63 foreach my $class ($self->class_precedence_list) {
64 next unless $class->can('meta');
65 foreach my $role (@{$class->meta->roles}) {
66 return 1 if $role->excludes_role($role_name);
73 my ($class, %params) = @_;
74 my $self = $class->SUPER::new_object(%params);
75 foreach my $attr ($class->compute_all_applicable_attributes()) {
77 # this does not accept undefined
78 # values, nor does it accept false
79 # values to be passed into the init-arg
80 next unless $params{$attr->init_arg} && $attr->can('has_trigger') && $attr->has_trigger;
81 $attr->trigger->($self, $params{$attr->init_arg}, $attr);
86 sub construct_instance {
87 my ($class, %params) = @_;
88 my $meta_instance = $class->get_meta_instance;
90 # the code below is almost certainly incorrect
91 # but this is foreign inheritence, so we might
92 # have to kludge it in the end.
93 my $instance = $params{'__INSTANCE__'} || $meta_instance->create_instance();
94 foreach my $attr ($class->compute_all_applicable_attributes()) {
95 $attr->initialize_instance_slot($meta_instance, $instance, \%params)
105 my $map = $self->{'%!methods'};
107 my $class_name = $self->name;
108 my $method_metaclass = $self->method_metaclass;
110 foreach my $symbol ($self->list_all_package_symbols('CODE')) {
112 my $code = $self->get_package_symbol('&' . $symbol);
114 next if exists $map->{$symbol} &&
115 defined $map->{$symbol} &&
116 $map->{$symbol}->body == $code;
118 my $gv = B::svref_2object($code)->GV;
120 my $pkg = $gv->STASH->NAME;
121 if ($pkg->can('meta') && $pkg->meta && $pkg->meta->isa('Moose::Meta::Role')) {
122 #my $role = $pkg->meta->name;
123 #next unless $self->does_role($role);
126 next if ($gv->STASH->NAME || '') ne $class_name &&
127 ($gv->NAME || '') ne '__ANON__';
130 $map->{$symbol} = $method_metaclass->wrap($code);
136 ### ---------------------------------------------
141 if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
143 # if it is a HASH ref, we de-ref it.
144 # this will usually mean that it is
146 $self->SUPER::add_attribute($name => %{$_[0]});
149 # otherwise we just pass the args
150 $self->SUPER::add_attribute($name => @_);
154 sub add_override_method_modifier {
155 my ($self, $name, $method, $_super_package) = @_;
156 (!$self->has_method($name))
157 || confess "Cannot add an override method if a local method is already present";
158 # need this for roles ...
159 $_super_package ||= $self->name;
160 my $super = $self->find_next_method_by_name($name);
162 || confess "You cannot override '$name' because it has no super method";
163 $self->add_method($name => Moose::Meta::Method::Overriden->wrap(sub {
166 no warnings 'redefine';
167 local *{$_super_package . '::super'} = sub { $super->(@args) };
168 return $method->(@args);
172 sub add_augment_method_modifier {
173 my ($self, $name, $method) = @_;
174 (!$self->has_method($name))
175 || confess "Cannot add an augment method if a local method is already present";
176 my $super = $self->find_next_method_by_name($name);
178 || confess "You cannot augment '$name' because it has no super method";
179 my $_super_package = $super->package_name;
180 # BUT!,... if this is an overriden method ....
181 if ($super->isa('Moose::Meta::Method::Overriden')) {
182 # we need to be sure that we actually
183 # find the next method, which is not
184 # an 'override' method, the reason is
185 # that an 'override' method will not
186 # be the one calling inner()
187 my $real_super = $self->_find_next_method_by_name_which_is_not_overridden($name);
188 $_super_package = $real_super->package_name;
190 $self->add_method($name => sub {
193 no warnings 'redefine';
194 local *{$_super_package . '::inner'} = sub { $method->(@args) };
195 return $super->(@args);
199 ## Private Utility methods ...
201 sub _find_next_method_by_name_which_is_not_overridden {
202 my ($self, $name) = @_;
203 foreach my $method ($self->find_all_methods_by_name($name)) {
204 return $method->{code}
205 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
210 sub _fix_metaclass_incompatability {
211 my ($self, @superclasses) = @_;
212 foreach my $super (@superclasses) {
213 # don't bother if it does not have a meta.
214 next unless $super->can('meta');
215 # get the name, make sure we take
216 # immutable classes into account
217 my $super_meta_name = ($super->meta->is_immutable
218 ? $super->meta->get_mutable_metaclass_name
219 : blessed($super->meta));
220 # if it's meta is a vanilla Moose,
221 # then we can safely ignore it.
222 next if $super_meta_name eq 'Moose::Meta::Class';
223 # but if we have anything else,
224 # we need to check it out ...
225 unless (# see if of our metaclass is incompatible
226 ($self->isa($super_meta_name) &&
227 # and see if our instance metaclass is incompatible
228 $self->instance_metaclass->isa($super->meta->instance_metaclass)) &&
229 # ... and if we are just a vanilla Moose
230 $self->isa('Moose::Meta::Class')) {
231 # re-initialize the meta ...
232 my $super_meta = $super->meta;
234 # We might want to consider actually
235 # transfering any attributes from the
236 # original meta into this one, but in
237 # general you should not have any there
238 # at this point anyway, so it's very
239 # much an obscure edge case anyway
240 $self = $super_meta->reinitialize($self->name => (
241 'attribute_metaclass' => $super_meta->attribute_metaclass,
242 'method_metaclass' => $super_meta->method_metaclass,
243 'instance_metaclass' => $super_meta->instance_metaclass,
250 sub _apply_all_roles {
251 my ($self, @roles) = @_;
252 ($_->can('meta') && $_->meta->isa('Moose::Meta::Role'))
253 || confess "You can only consume roles, $_ is not a Moose role"
255 if (scalar @roles == 1) {
256 $roles[0]->meta->apply($self);
260 # we should make a Moose::Meta::Role::Composite
261 # which is a smaller version of Moose::Meta::Role
262 # which does not use any package stuff
263 Moose::Meta::Role->combine(
264 map { $_->meta } @roles
269 sub _process_attribute {
270 my ($self, $name, %options) = @_;
271 if ($name =~ /^\+(.*)/) {
272 my $new_attr = $self->_process_inherited_attribute($1, %options);
273 $self->add_attribute($new_attr);
276 if ($options{metaclass}) {
277 Moose::_load_all_classes($options{metaclass});
278 $self->add_attribute($options{metaclass}->new($name, %options));
281 $self->add_attribute($name, %options);
286 sub _process_inherited_attribute {
287 my ($self, $attr_name, %options) = @_;
288 my $inherited_attr = $self->find_attribute_by_name($attr_name);
289 (defined $inherited_attr)
290 || confess "Could not find an attribute by the name of '$attr_name' to inherit from";
292 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
293 $new_attr = $inherited_attr->clone_and_inherit_options(%options);
297 # kind of a kludge to handle Class::MOP::Attributes
298 $new_attr = Moose::Meta::Attribute::clone_and_inherit_options(
299 $inherited_attr, %options
305 ## -------------------------------------------------
307 use Moose::Meta::Method::Constructor;
308 use Moose::Meta::Method::Destructor;
312 # the immutable version of a
313 # particular metaclass is
314 # really class-level data so
315 # we don't want to regenerate
316 # it any more than we need to
317 my $IMMUTABLE_METACLASS;
321 $IMMUTABLE_METACLASS ||= Class::MOP::Immutable->new($self, {
322 read_only => [qw/superclasses/],
330 remove_package_symbol
334 class_precedence_list => 'ARRAY',
335 compute_all_applicable_attributes => 'ARRAY',
336 get_meta_instance => 'SCALAR',
337 get_method_map => 'SCALAR',
339 calculate_all_roles => 'ARRAY',
343 $IMMUTABLE_METACLASS->make_metaclass_immutable(
345 constructor_class => 'Moose::Meta::Method::Constructor',
346 destructor_class => 'Moose::Meta::Method::Destructor',
347 inline_destructor => 1,
349 # no need to do this,
350 # Moose always does it
351 inline_accessors => 0,
365 Moose::Meta::Class - The Moose metaclass
369 This is a subclass of L<Class::MOP::Class> with Moose specific
372 For the most part, the only time you will ever encounter an
373 instance of this class is if you are doing some serious deep
374 introspection. To really understand this class, you need to refer
375 to the L<Class::MOP::Class> documentation.
383 =item B<make_immutable>
387 We override this method to support the C<trigger> attribute option.
389 =item B<construct_instance>
391 This provides some Moose specific extensions to this method, you
392 almost never call this method directly unless you really know what
395 This method makes sure to handle the moose weak-ref, type-constraint
396 and type coercion features.
398 =item B<get_method_map>
400 This accommodates Moose::Meta::Role::Method instances, which are
401 aliased, instead of added, but still need to be counted as valid
404 =item B<add_override_method_modifier ($name, $method)>
406 This will create an C<override> method modifier for you, and install
409 =item B<add_augment_method_modifier ($name, $method)>
411 This will create an C<augment> method modifier for you, and install
414 =item B<calculate_all_roles>
418 This will return an array of C<Moose::Meta::Role> instances which are
419 attached to this class.
421 =item B<add_role ($role)>
423 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
424 to the list of associated roles.
426 =item B<does_role ($role_name)>
428 This will test if this class C<does> a given C<$role_name>. It will
429 not only check it's local roles, but ask them as well in order to
430 cascade down the role hierarchy.
432 =item B<excludes_role ($role_name)>
434 This will test if this class C<excludes> a given C<$role_name>. It will
435 not only check it's local roles, but ask them as well in order to
436 cascade down the role hierarchy.
438 =item B<add_attribute ($attr_name, %params|$params)>
440 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
441 support for taking the C<$params> as a HASH ref.
447 All complex software has bugs lurking in it, and this module is no
448 exception. If you find a bug please either email me, or add the bug
453 Stevan Little E<lt>stevan@iinteractive.comE<gt>
455 =head1 COPYRIGHT AND LICENSE
457 Copyright 2006 by Infinity Interactive, Inc.
459 L<http://www.iinteractive.com>
461 This library is free software; you can redistribute it and/or modify
462 it under the same terms as Perl itself.