2 package Moose::Meta::Class;
10 use Scalar::Util 'weaken', 'blessed', 'reftype';
12 our $VERSION = '0.13';
13 our $AUTHORITY = 'cpan:STEVAN';
15 use Moose::Meta::Method::Overriden;
17 use base 'Class::MOP::Class';
19 __PACKAGE__->meta->add_attribute('roles' => (
27 $class->SUPER::initialize($pkg,
28 'attribute_metaclass' => 'Moose::Meta::Attribute',
29 'method_metaclass' => 'Moose::Meta::Method',
30 'instance_metaclass' => 'Moose::Meta::Instance',
35 my ($self, $role) = @_;
36 (blessed($role) && $role->isa('Moose::Meta::Role'))
37 || confess "Roles must be instances of Moose::Meta::Role";
38 push @{$self->roles} => $role;
41 sub calculate_all_roles {
44 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
48 my ($self, $role_name) = @_;
50 || confess "You must supply a role name to look for";
51 foreach my $class ($self->class_precedence_list) {
52 next unless $class->can('meta');
53 foreach my $role (@{$class->meta->roles}) {
54 return 1 if $role->does_role($role_name);
61 my ($self, $role_name) = @_;
63 || confess "You must supply a role name to look for";
64 foreach my $class ($self->class_precedence_list) {
65 next unless $class->can('meta');
67 # in the pretty rare instance when a Moose metaclass
68 # is itself extended with a role, this check needs to
69 # be done since some items in the class_precedence_list
70 # might in fact be Class::MOP based still.
71 next unless $class->meta->can('roles');
72 foreach my $role (@{$class->meta->roles}) {
73 return 1 if $role->excludes_role($role_name);
80 my ($class, %params) = @_;
81 my $self = $class->SUPER::new_object(%params);
82 foreach my $attr ($class->compute_all_applicable_attributes()) {
84 # this does not accept undefined
85 # values, nor does it accept false
86 # values to be passed into the init-arg
87 next unless $params{$attr->init_arg} && $attr->can('has_trigger') && $attr->has_trigger;
88 $attr->trigger->($self, $params{$attr->init_arg}, $attr);
93 sub construct_instance {
94 my ($class, %params) = @_;
95 my $meta_instance = $class->get_meta_instance;
97 # the code below is almost certainly incorrect
98 # but this is foreign inheritence, so we might
99 # have to kludge it in the end.
100 my $instance = $params{'__INSTANCE__'} || $meta_instance->create_instance();
101 foreach my $attr ($class->compute_all_applicable_attributes()) {
102 $attr->initialize_instance_slot($meta_instance, $instance, \%params)
112 my $map = $self->{'%!methods'};
114 my $class_name = $self->name;
115 my $method_metaclass = $self->method_metaclass;
117 foreach my $symbol ($self->list_all_package_symbols('CODE')) {
119 my $code = $self->get_package_symbol('&' . $symbol);
121 next if exists $map->{$symbol} &&
122 defined $map->{$symbol} &&
123 $map->{$symbol}->body == $code;
125 my $gv = B::svref_2object($code)->GV;
127 my $pkg = $gv->STASH->NAME;
128 if ($pkg->can('meta') && $pkg->meta && $pkg->meta->isa('Moose::Meta::Role')) {
129 #my $role = $pkg->meta->name;
130 #next unless $self->does_role($role);
133 next if ($gv->STASH->NAME || '') ne $class_name &&
134 ($gv->NAME || '') ne '__ANON__';
137 $map->{$symbol} = $method_metaclass->wrap($code);
143 ### ---------------------------------------------
148 if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
150 # if it is a HASH ref, we de-ref it.
151 # this will usually mean that it is
153 $self->SUPER::add_attribute($name => %{$_[0]});
156 # otherwise we just pass the args
157 $self->SUPER::add_attribute($name => @_);
161 sub add_override_method_modifier {
162 my ($self, $name, $method, $_super_package) = @_;
163 (!$self->has_method($name))
164 || confess "Cannot add an override method if a local method is already present";
165 # need this for roles ...
166 $_super_package ||= $self->name;
167 my $super = $self->find_next_method_by_name($name);
169 || confess "You cannot override '$name' because it has no super method";
170 $self->add_method($name => Moose::Meta::Method::Overriden->wrap(sub {
172 no warnings 'redefine';
173 if ($Moose::SUPER_SLOT{$_super_package}) {
174 local *{$Moose::SUPER_SLOT{$_super_package}}
175 = sub { $super->(@args) };
176 return $method->(@args);
178 confess "Trying to call override modifier'd method without super()";
183 sub add_augment_method_modifier {
184 my ($self, $name, $method) = @_;
185 (!$self->has_method($name))
186 || confess "Cannot add an augment method if a local method is already present";
187 my $super = $self->find_next_method_by_name($name);
189 || confess "You cannot augment '$name' because it has no super method";
190 my $_super_package = $super->package_name;
191 # BUT!,... if this is an overriden method ....
192 if ($super->isa('Moose::Meta::Method::Overriden')) {
193 # we need to be sure that we actually
194 # find the next method, which is not
195 # an 'override' method, the reason is
196 # that an 'override' method will not
197 # be the one calling inner()
198 my $real_super = $self->_find_next_method_by_name_which_is_not_overridden($name);
199 $_super_package = $real_super->package_name;
201 $self->add_method($name => sub {
203 no warnings 'redefine';
204 if ($Moose::INNER_SLOT{$_super_package}) {
205 local *{$Moose::INNER_SLOT{$_super_package}}
206 = sub { $method->(@args) };
207 return $super->(@args);
209 return $super->(@args);
214 ## Private Utility methods ...
216 sub _find_next_method_by_name_which_is_not_overridden {
217 my ($self, $name) = @_;
218 foreach my $method ($self->find_all_methods_by_name($name)) {
219 return $method->{code}
220 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
225 sub _fix_metaclass_incompatability {
226 my ($self, @superclasses) = @_;
227 foreach my $super (@superclasses) {
228 # don't bother if it does not have a meta.
229 next unless $super->can('meta');
230 # get the name, make sure we take
231 # immutable classes into account
232 my $super_meta_name = ($super->meta->is_immutable
233 ? $super->meta->get_mutable_metaclass_name
234 : blessed($super->meta));
235 # if it's meta is a vanilla Moose,
236 # then we can safely ignore it.
237 next if $super_meta_name eq 'Moose::Meta::Class';
238 # but if we have anything else,
239 # we need to check it out ...
240 unless (# see if of our metaclass is incompatible
241 ($self->isa($super_meta_name) &&
242 # and see if our instance metaclass is incompatible
243 $self->instance_metaclass->isa($super->meta->instance_metaclass)) &&
244 # ... and if we are just a vanilla Moose
245 $self->isa('Moose::Meta::Class')) {
246 # re-initialize the meta ...
247 my $super_meta = $super->meta;
249 # We might want to consider actually
250 # transfering any attributes from the
251 # original meta into this one, but in
252 # general you should not have any there
253 # at this point anyway, so it's very
254 # much an obscure edge case anyway
255 $self = $super_meta->reinitialize($self->name => (
256 'attribute_metaclass' => $super_meta->attribute_metaclass,
257 'method_metaclass' => $super_meta->method_metaclass,
258 'instance_metaclass' => $super_meta->instance_metaclass,
265 sub _apply_all_roles {
266 my ($self, @roles) = @_;
267 ($_->can('meta') && $_->meta->isa('Moose::Meta::Role'))
268 || confess "You can only consume roles, $_ is not a Moose role"
270 if (scalar @roles == 1) {
271 $roles[0]->meta->apply($self);
275 # we should make a Moose::Meta::Role::Composite
276 # which is a smaller version of Moose::Meta::Role
277 # which does not use any package stuff
278 Moose::Meta::Role->combine(
279 map { $_->meta } @roles
284 sub _process_attribute {
285 my ($self, $name, %options) = @_;
286 if ($name =~ /^\+(.*)/) {
287 my $new_attr = $self->_process_inherited_attribute($1, %options);
288 $self->add_attribute($new_attr);
291 if ($options{metaclass}) {
292 my $metaclass_name = $options{metaclass};
294 my $possible_full_name = 'Moose::Meta::Attribute::Custom::' . $metaclass_name;
295 Class::MOP::load_class($possible_full_name);
296 $metaclass_name = $possible_full_name->can('register_implementation')
297 ? $possible_full_name->register_implementation
298 : $possible_full_name;
301 Class::MOP::load_class($metaclass_name);
303 $self->add_attribute($metaclass_name->new($name, %options));
306 $self->add_attribute($name, %options);
311 sub _process_inherited_attribute {
312 my ($self, $attr_name, %options) = @_;
313 my $inherited_attr = $self->find_attribute_by_name($attr_name);
314 (defined $inherited_attr)
315 || confess "Could not find an attribute by the name of '$attr_name' to inherit from";
317 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
318 $new_attr = $inherited_attr->clone_and_inherit_options(%options);
322 # kind of a kludge to handle Class::MOP::Attributes
323 $new_attr = Moose::Meta::Attribute::clone_and_inherit_options(
324 $inherited_attr, %options
330 ## -------------------------------------------------
332 use Moose::Meta::Method::Constructor;
333 use Moose::Meta::Method::Destructor;
337 # the immutable version of a
338 # particular metaclass is
339 # really class-level data so
340 # we don't want to regenerate
341 # it any more than we need to
342 my $IMMUTABLE_METACLASS;
346 $IMMUTABLE_METACLASS ||= Class::MOP::Immutable->new($self, {
347 read_only => [qw/superclasses/],
355 remove_package_symbol
359 class_precedence_list => 'ARRAY',
360 compute_all_applicable_attributes => 'ARRAY',
361 get_meta_instance => 'SCALAR',
362 get_method_map => 'SCALAR',
364 calculate_all_roles => 'ARRAY',
368 $IMMUTABLE_METACLASS->make_metaclass_immutable(
370 constructor_class => 'Moose::Meta::Method::Constructor',
371 destructor_class => 'Moose::Meta::Method::Destructor',
372 inline_destructor => 1,
374 # no need to do this,
375 # Moose always does it
376 inline_accessors => 0,
390 Moose::Meta::Class - The Moose metaclass
394 This is a subclass of L<Class::MOP::Class> with Moose specific
397 For the most part, the only time you will ever encounter an
398 instance of this class is if you are doing some serious deep
399 introspection. To really understand this class, you need to refer
400 to the L<Class::MOP::Class> documentation.
408 =item B<make_immutable>
412 We override this method to support the C<trigger> attribute option.
414 =item B<construct_instance>
416 This provides some Moose specific extensions to this method, you
417 almost never call this method directly unless you really know what
420 This method makes sure to handle the moose weak-ref, type-constraint
421 and type coercion features.
423 =item B<get_method_map>
425 This accommodates Moose::Meta::Role::Method instances, which are
426 aliased, instead of added, but still need to be counted as valid
429 =item B<add_override_method_modifier ($name, $method)>
431 This will create an C<override> method modifier for you, and install
434 =item B<add_augment_method_modifier ($name, $method)>
436 This will create an C<augment> method modifier for you, and install
439 =item B<calculate_all_roles>
443 This will return an array of C<Moose::Meta::Role> instances which are
444 attached to this class.
446 =item B<add_role ($role)>
448 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
449 to the list of associated roles.
451 =item B<does_role ($role_name)>
453 This will test if this class C<does> a given C<$role_name>. It will
454 not only check it's local roles, but ask them as well in order to
455 cascade down the role hierarchy.
457 =item B<excludes_role ($role_name)>
459 This will test if this class C<excludes> a given C<$role_name>. It will
460 not only check it's local roles, but ask them as well in order to
461 cascade down the role hierarchy.
463 =item B<add_attribute ($attr_name, %params|$params)>
465 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
466 support for taking the C<$params> as a HASH ref.
472 All complex software has bugs lurking in it, and this module is no
473 exception. If you find a bug please either email me, or add the bug
478 Stevan Little E<lt>stevan@iinteractive.comE<gt>
480 =head1 COPYRIGHT AND LICENSE
482 Copyright 2006, 2007 by Infinity Interactive, Inc.
484 L<http://www.iinteractive.com>
486 This library is free software; you can redistribute it and/or modify
487 it under the same terms as Perl itself.