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 {
173 no warnings 'redefine';
174 local *{$_super_package . '::super'} = sub { $super->(@args) };
175 return $method->(@args);
179 sub add_augment_method_modifier {
180 my ($self, $name, $method) = @_;
181 (!$self->has_method($name))
182 || confess "Cannot add an augment method if a local method is already present";
183 my $super = $self->find_next_method_by_name($name);
185 || confess "You cannot augment '$name' because it has no super method";
186 my $_super_package = $super->package_name;
187 # BUT!,... if this is an overriden method ....
188 if ($super->isa('Moose::Meta::Method::Overriden')) {
189 # we need to be sure that we actually
190 # find the next method, which is not
191 # an 'override' method, the reason is
192 # that an 'override' method will not
193 # be the one calling inner()
194 my $real_super = $self->_find_next_method_by_name_which_is_not_overridden($name);
195 $_super_package = $real_super->package_name;
197 $self->add_method($name => sub {
200 no warnings 'redefine';
201 local *{$_super_package . '::inner'} = sub { $method->(@args) };
202 return $super->(@args);
206 ## Private Utility methods ...
208 sub _find_next_method_by_name_which_is_not_overridden {
209 my ($self, $name) = @_;
210 foreach my $method ($self->find_all_methods_by_name($name)) {
211 return $method->{code}
212 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
217 sub _fix_metaclass_incompatability {
218 my ($self, @superclasses) = @_;
219 foreach my $super (@superclasses) {
220 # don't bother if it does not have a meta.
221 next unless $super->can('meta');
222 # get the name, make sure we take
223 # immutable classes into account
224 my $super_meta_name = ($super->meta->is_immutable
225 ? $super->meta->get_mutable_metaclass_name
226 : blessed($super->meta));
227 # if it's meta is a vanilla Moose,
228 # then we can safely ignore it.
229 next if $super_meta_name eq 'Moose::Meta::Class';
230 # but if we have anything else,
231 # we need to check it out ...
232 unless (# see if of our metaclass is incompatible
233 ($self->isa($super_meta_name) &&
234 # and see if our instance metaclass is incompatible
235 $self->instance_metaclass->isa($super->meta->instance_metaclass)) &&
236 # ... and if we are just a vanilla Moose
237 $self->isa('Moose::Meta::Class')) {
238 # re-initialize the meta ...
239 my $super_meta = $super->meta;
241 # We might want to consider actually
242 # transfering any attributes from the
243 # original meta into this one, but in
244 # general you should not have any there
245 # at this point anyway, so it's very
246 # much an obscure edge case anyway
247 $self = $super_meta->reinitialize($self->name => (
248 'attribute_metaclass' => $super_meta->attribute_metaclass,
249 'method_metaclass' => $super_meta->method_metaclass,
250 'instance_metaclass' => $super_meta->instance_metaclass,
257 sub _apply_all_roles {
258 my ($self, @roles) = @_;
259 ($_->can('meta') && $_->meta->isa('Moose::Meta::Role'))
260 || confess "You can only consume roles, $_ is not a Moose role"
262 if (scalar @roles == 1) {
263 $roles[0]->meta->apply($self);
267 # we should make a Moose::Meta::Role::Composite
268 # which is a smaller version of Moose::Meta::Role
269 # which does not use any package stuff
270 Moose::Meta::Role->combine(
271 map { $_->meta } @roles
276 sub _process_attribute {
277 my ($self, $name, %options) = @_;
278 if ($name =~ /^\+(.*)/) {
279 my $new_attr = $self->_process_inherited_attribute($1, %options);
280 $self->add_attribute($new_attr);
283 if ($options{metaclass}) {
284 my $metaclass_name = $options{metaclass};
286 my $possible_full_name = 'Moose::Meta::Attribute::Custom::' . $metaclass_name;
287 Class::MOP::load_class($possible_full_name);
288 $metaclass_name = $possible_full_name->can('register_implementation')
289 ? $possible_full_name->register_implementation
290 : $possible_full_name;
293 Class::MOP::load_class($metaclass_name);
295 $self->add_attribute($metaclass_name->new($name, %options));
298 $self->add_attribute($name, %options);
303 sub _process_inherited_attribute {
304 my ($self, $attr_name, %options) = @_;
305 my $inherited_attr = $self->find_attribute_by_name($attr_name);
306 (defined $inherited_attr)
307 || confess "Could not find an attribute by the name of '$attr_name' to inherit from";
309 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
310 $new_attr = $inherited_attr->clone_and_inherit_options(%options);
314 # kind of a kludge to handle Class::MOP::Attributes
315 $new_attr = Moose::Meta::Attribute::clone_and_inherit_options(
316 $inherited_attr, %options
322 ## -------------------------------------------------
324 use Moose::Meta::Method::Constructor;
325 use Moose::Meta::Method::Destructor;
329 # the immutable version of a
330 # particular metaclass is
331 # really class-level data so
332 # we don't want to regenerate
333 # it any more than we need to
334 my $IMMUTABLE_METACLASS;
338 $IMMUTABLE_METACLASS ||= Class::MOP::Immutable->new($self, {
339 read_only => [qw/superclasses/],
347 remove_package_symbol
351 class_precedence_list => 'ARRAY',
352 compute_all_applicable_attributes => 'ARRAY',
353 get_meta_instance => 'SCALAR',
354 get_method_map => 'SCALAR',
356 calculate_all_roles => 'ARRAY',
360 $IMMUTABLE_METACLASS->make_metaclass_immutable(
362 constructor_class => 'Moose::Meta::Method::Constructor',
363 destructor_class => 'Moose::Meta::Method::Destructor',
364 inline_destructor => 1,
366 # no need to do this,
367 # Moose always does it
368 inline_accessors => 0,
382 Moose::Meta::Class - The Moose metaclass
386 This is a subclass of L<Class::MOP::Class> with Moose specific
389 For the most part, the only time you will ever encounter an
390 instance of this class is if you are doing some serious deep
391 introspection. To really understand this class, you need to refer
392 to the L<Class::MOP::Class> documentation.
400 =item B<make_immutable>
404 We override this method to support the C<trigger> attribute option.
406 =item B<construct_instance>
408 This provides some Moose specific extensions to this method, you
409 almost never call this method directly unless you really know what
412 This method makes sure to handle the moose weak-ref, type-constraint
413 and type coercion features.
415 =item B<get_method_map>
417 This accommodates Moose::Meta::Role::Method instances, which are
418 aliased, instead of added, but still need to be counted as valid
421 =item B<add_override_method_modifier ($name, $method)>
423 This will create an C<override> method modifier for you, and install
426 =item B<add_augment_method_modifier ($name, $method)>
428 This will create an C<augment> method modifier for you, and install
431 =item B<calculate_all_roles>
435 This will return an array of C<Moose::Meta::Role> instances which are
436 attached to this class.
438 =item B<add_role ($role)>
440 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
441 to the list of associated roles.
443 =item B<does_role ($role_name)>
445 This will test if this class C<does> a given C<$role_name>. It will
446 not only check it's local roles, but ask them as well in order to
447 cascade down the role hierarchy.
449 =item B<excludes_role ($role_name)>
451 This will test if this class C<excludes> a given C<$role_name>. It will
452 not only check it's local roles, but ask them as well in order to
453 cascade down the role hierarchy.
455 =item B<add_attribute ($attr_name, %params|$params)>
457 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
458 support for taking the C<$params> as a HASH ref.
464 All complex software has bugs lurking in it, and this module is no
465 exception. If you find a bug please either email me, or add the bug
470 Stevan Little E<lt>stevan@iinteractive.comE<gt>
472 =head1 COPYRIGHT AND LICENSE
474 Copyright 2006, 2007 by Infinity Interactive, Inc.
476 L<http://www.iinteractive.com>
478 This library is free software; you can redistribute it and/or modify
479 it under the same terms as Perl itself.