2 package Moose::Meta::Class;
10 use Scalar::Util 'weaken', 'blessed', 'reftype';
12 our $VERSION = '0.12';
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');
66 foreach my $role (@{$class->meta->roles}) {
67 return 1 if $role->excludes_role($role_name);
74 my ($class, %params) = @_;
75 my $self = $class->SUPER::new_object(%params);
76 foreach my $attr ($class->compute_all_applicable_attributes()) {
78 # this does not accept undefined
79 # values, nor does it accept false
80 # values to be passed into the init-arg
81 next unless $params{$attr->init_arg} && $attr->can('has_trigger') && $attr->has_trigger;
82 $attr->trigger->($self, $params{$attr->init_arg}, $attr);
87 sub construct_instance {
88 my ($class, %params) = @_;
89 my $meta_instance = $class->get_meta_instance;
91 # the code below is almost certainly incorrect
92 # but this is foreign inheritence, so we might
93 # have to kludge it in the end.
94 my $instance = $params{'__INSTANCE__'} || $meta_instance->create_instance();
95 foreach my $attr ($class->compute_all_applicable_attributes()) {
96 $attr->initialize_instance_slot($meta_instance, $instance, \%params)
106 my $map = $self->{'%!methods'};
108 my $class_name = $self->name;
109 my $method_metaclass = $self->method_metaclass;
111 foreach my $symbol ($self->list_all_package_symbols('CODE')) {
113 my $code = $self->get_package_symbol('&' . $symbol);
115 next if exists $map->{$symbol} &&
116 defined $map->{$symbol} &&
117 $map->{$symbol}->body == $code;
119 my $gv = B::svref_2object($code)->GV;
121 my $pkg = $gv->STASH->NAME;
122 if ($pkg->can('meta') && $pkg->meta && $pkg->meta->isa('Moose::Meta::Role')) {
123 #my $role = $pkg->meta->name;
124 #next unless $self->does_role($role);
127 next if ($gv->STASH->NAME || '') ne $class_name &&
128 ($gv->NAME || '') ne '__ANON__';
131 $map->{$symbol} = $method_metaclass->wrap($code);
137 ### ---------------------------------------------
142 if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
144 # if it is a HASH ref, we de-ref it.
145 # this will usually mean that it is
147 $self->SUPER::add_attribute($name => %{$_[0]});
150 # otherwise we just pass the args
151 $self->SUPER::add_attribute($name => @_);
155 sub add_override_method_modifier {
156 my ($self, $name, $method, $_super_package) = @_;
157 (!$self->has_method($name))
158 || confess "Cannot add an override method if a local method is already present";
159 # need this for roles ...
160 $_super_package ||= $self->name;
161 my $super = $self->find_next_method_by_name($name);
163 || confess "You cannot override '$name' because it has no super method";
164 $self->add_method($name => Moose::Meta::Method::Overriden->wrap(sub {
167 no warnings 'redefine';
168 local *{$_super_package . '::super'} = sub { $super->(@args) };
169 return $method->(@args);
173 sub add_augment_method_modifier {
174 my ($self, $name, $method) = @_;
175 (!$self->has_method($name))
176 || confess "Cannot add an augment method if a local method is already present";
177 my $super = $self->find_next_method_by_name($name);
179 || confess "You cannot augment '$name' because it has no super method";
180 my $_super_package = $super->package_name;
181 # BUT!,... if this is an overriden method ....
182 if ($super->isa('Moose::Meta::Method::Overriden')) {
183 # we need to be sure that we actually
184 # find the next method, which is not
185 # an 'override' method, the reason is
186 # that an 'override' method will not
187 # be the one calling inner()
188 my $real_super = $self->_find_next_method_by_name_which_is_not_overridden($name);
189 $_super_package = $real_super->package_name;
191 $self->add_method($name => sub {
194 no warnings 'redefine';
195 local *{$_super_package . '::inner'} = sub { $method->(@args) };
196 return $super->(@args);
200 ## Private Utility methods ...
202 sub _find_next_method_by_name_which_is_not_overridden {
203 my ($self, $name) = @_;
204 foreach my $method ($self->find_all_methods_by_name($name)) {
205 return $method->{code}
206 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
211 sub _fix_metaclass_incompatability {
212 my ($self, @superclasses) = @_;
213 foreach my $super (@superclasses) {
214 # don't bother if it does not have a meta.
215 next unless $super->can('meta');
216 # get the name, make sure we take
217 # immutable classes into account
218 my $super_meta_name = ($super->meta->is_immutable
219 ? $super->meta->get_mutable_metaclass_name
220 : blessed($super->meta));
221 # if it's meta is a vanilla Moose,
222 # then we can safely ignore it.
223 next if $super_meta_name eq 'Moose::Meta::Class';
224 # but if we have anything else,
225 # we need to check it out ...
226 unless (# see if of our metaclass is incompatible
227 ($self->isa($super_meta_name) &&
228 # and see if our instance metaclass is incompatible
229 $self->instance_metaclass->isa($super->meta->instance_metaclass)) &&
230 # ... and if we are just a vanilla Moose
231 $self->isa('Moose::Meta::Class')) {
232 # re-initialize the meta ...
233 my $super_meta = $super->meta;
235 # We might want to consider actually
236 # transfering any attributes from the
237 # original meta into this one, but in
238 # general you should not have any there
239 # at this point anyway, so it's very
240 # much an obscure edge case anyway
241 $self = $super_meta->reinitialize($self->name => (
242 'attribute_metaclass' => $super_meta->attribute_metaclass,
243 'method_metaclass' => $super_meta->method_metaclass,
244 'instance_metaclass' => $super_meta->instance_metaclass,
251 sub _apply_all_roles {
252 my ($self, @roles) = @_;
253 ($_->can('meta') && $_->meta->isa('Moose::Meta::Role'))
254 || confess "You can only consume roles, $_ is not a Moose role"
256 if (scalar @roles == 1) {
257 $roles[0]->meta->apply($self);
261 # we should make a Moose::Meta::Role::Composite
262 # which is a smaller version of Moose::Meta::Role
263 # which does not use any package stuff
264 Moose::Meta::Role->combine(
265 map { $_->meta } @roles
270 sub _process_attribute {
271 my ($self, $name, %options) = @_;
272 if ($name =~ /^\+(.*)/) {
273 my $new_attr = $self->_process_inherited_attribute($1, %options);
274 $self->add_attribute($new_attr);
277 if ($options{metaclass}) {
278 my $metaclass_name = $options{metaclass};
280 my $possible_full_name = 'Moose::Meta::Attribute::Custom::' . $metaclass_name;
281 Class::MOP::load_class($possible_full_name);
282 $metaclass_name = $possible_full_name->can('register_implementation')
283 ? $possible_full_name->register_implementation
284 : $possible_full_name;
287 Class::MOP::load_class($metaclass_name);
289 $self->add_attribute($metaclass_name->new($name, %options));
292 $self->add_attribute($name, %options);
297 sub _process_inherited_attribute {
298 my ($self, $attr_name, %options) = @_;
299 my $inherited_attr = $self->find_attribute_by_name($attr_name);
300 (defined $inherited_attr)
301 || confess "Could not find an attribute by the name of '$attr_name' to inherit from";
303 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
304 $new_attr = $inherited_attr->clone_and_inherit_options(%options);
308 # kind of a kludge to handle Class::MOP::Attributes
309 $new_attr = Moose::Meta::Attribute::clone_and_inherit_options(
310 $inherited_attr, %options
316 ## -------------------------------------------------
318 use Moose::Meta::Method::Constructor;
319 use Moose::Meta::Method::Destructor;
323 # the immutable version of a
324 # particular metaclass is
325 # really class-level data so
326 # we don't want to regenerate
327 # it any more than we need to
328 my $IMMUTABLE_METACLASS;
332 $IMMUTABLE_METACLASS ||= Class::MOP::Immutable->new($self, {
333 read_only => [qw/superclasses/],
341 remove_package_symbol
345 class_precedence_list => 'ARRAY',
346 compute_all_applicable_attributes => 'ARRAY',
347 get_meta_instance => 'SCALAR',
348 get_method_map => 'SCALAR',
350 calculate_all_roles => 'ARRAY',
354 $IMMUTABLE_METACLASS->make_metaclass_immutable(
356 constructor_class => 'Moose::Meta::Method::Constructor',
357 destructor_class => 'Moose::Meta::Method::Destructor',
358 inline_destructor => 1,
360 # no need to do this,
361 # Moose always does it
362 inline_accessors => 0,
376 Moose::Meta::Class - The Moose metaclass
380 This is a subclass of L<Class::MOP::Class> with Moose specific
383 For the most part, the only time you will ever encounter an
384 instance of this class is if you are doing some serious deep
385 introspection. To really understand this class, you need to refer
386 to the L<Class::MOP::Class> documentation.
394 =item B<make_immutable>
398 We override this method to support the C<trigger> attribute option.
400 =item B<construct_instance>
402 This provides some Moose specific extensions to this method, you
403 almost never call this method directly unless you really know what
406 This method makes sure to handle the moose weak-ref, type-constraint
407 and type coercion features.
409 =item B<get_method_map>
411 This accommodates Moose::Meta::Role::Method instances, which are
412 aliased, instead of added, but still need to be counted as valid
415 =item B<add_override_method_modifier ($name, $method)>
417 This will create an C<override> method modifier for you, and install
420 =item B<add_augment_method_modifier ($name, $method)>
422 This will create an C<augment> method modifier for you, and install
425 =item B<calculate_all_roles>
429 This will return an array of C<Moose::Meta::Role> instances which are
430 attached to this class.
432 =item B<add_role ($role)>
434 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
435 to the list of associated roles.
437 =item B<does_role ($role_name)>
439 This will test if this class C<does> a given C<$role_name>. It will
440 not only check it's local roles, but ask them as well in order to
441 cascade down the role hierarchy.
443 =item B<excludes_role ($role_name)>
445 This will test if this class C<excludes> 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<add_attribute ($attr_name, %params|$params)>
451 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
452 support for taking the C<$params> as a HASH ref.
458 All complex software has bugs lurking in it, and this module is no
459 exception. If you find a bug please either email me, or add the bug
464 Stevan Little E<lt>stevan@iinteractive.comE<gt>
466 =head1 COPYRIGHT AND LICENSE
468 Copyright 2006, 2007 by Infinity Interactive, Inc.
470 L<http://www.iinteractive.com>
472 This library is free software; you can redistribute it and/or modify
473 it under the same terms as Perl itself.