2 package Moose::Meta::Class;
10 use Scalar::Util 'weaken', 'blessed', 'reftype';
12 our $VERSION = '0.07';
14 use base 'Class::MOP::Class';
16 __PACKAGE__->meta->add_attribute('roles' => (
24 $class->SUPER::initialize($pkg,
25 ':attribute_metaclass' => 'Moose::Meta::Attribute',
26 ':instance_metaclass' => 'Moose::Meta::Instance',
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;
38 my ($self, $role_name) = @_;
40 || confess "You must supply a role name to look for";
41 foreach my $class ($self->class_precedence_list) {
42 next unless $class->can('meta');
43 foreach my $role (@{$class->meta->roles}) {
44 return 1 if $role->does_role($role_name);
51 my ($self, $role_name) = @_;
53 || confess "You must supply a role name to look for";
54 foreach my $class ($self->class_precedence_list) {
55 next unless $class->can('meta');
56 foreach my $role (@{$class->meta->roles}) {
57 return 1 if $role->excludes_role($role_name);
64 my ($class, %params) = @_;
65 my $self = $class->SUPER::new_object(%params);
66 foreach my $attr ($class->compute_all_applicable_attributes()) {
68 # this does not accept undefined
69 # values, nor does it accept false
70 # values to be passed into the init-arg
71 next unless $params{$attr->init_arg} && $attr->can('has_trigger') && $attr->has_trigger;
72 $attr->trigger->($self, $params{$attr->init_arg}, $attr);
77 sub construct_instance {
78 my ($class, %params) = @_;
79 my $meta_instance = $class->get_meta_instance;
81 # the code below is almost certainly incorrect
82 # but this is foreign inheritence, so we might
83 # have to kludge it in the end.
84 my $instance = $params{'__INSTANCE__'} || $meta_instance->create_instance();
85 foreach my $attr ($class->compute_all_applicable_attributes()) {
86 $attr->initialize_instance_slot($meta_instance, $instance, \%params)
92 my ($self, $method_name) = @_;
93 (defined $method_name && $method_name)
94 || confess "You must define a method name";
96 my $sub_name = ($self->name . '::' . $method_name);
99 return 0 if !defined(&{$sub_name});
100 my $method = \&{$sub_name};
102 return 1 if blessed($method) && $method->isa('Moose::Meta::Role::Method');
103 return $self->SUPER::has_method($method_name);
109 if (scalar @_ == 1 && ref($_[0]) eq 'HASH') {
111 # if it is a HASH ref, we de-ref it.
112 # this will usually mean that it is
114 $self->SUPER::add_attribute($name => %{$_[0]});
117 # otherwise we just pass the args
118 $self->SUPER::add_attribute($name => @_);
122 sub add_override_method_modifier {
123 my ($self, $name, $method, $_super_package) = @_;
124 (!$self->has_method($name))
125 || confess "Cannot add an override method if a local method is already present";
126 # need this for roles ...
127 $_super_package ||= $self->name;
128 my $super = $self->find_next_method_by_name($name);
130 || confess "You cannot override '$name' because it has no super method";
131 $self->add_method($name => bless sub {
134 no warnings 'redefine';
135 local *{$_super_package . '::super'} = sub { $super->(@args) };
136 return $method->(@args);
137 } => 'Moose::Meta::Method::Overriden');
140 sub add_augment_method_modifier {
141 my ($self, $name, $method) = @_;
142 (!$self->has_method($name))
143 || confess "Cannot add an augment method if a local method is already present";
144 my $super = $self->find_next_method_by_name($name);
146 || confess "You cannot augment '$name' because it has no super method";
147 my $_super_package = $super->package_name;
148 # BUT!,... if this is an overriden method ....
149 if ($super->isa('Moose::Meta::Method::Overriden')) {
150 # we need to be sure that we actually
151 # find the next method, which is not
152 # an 'override' method, the reason is
153 # that an 'override' method will not
154 # be the one calling inner()
155 my $real_super = $self->_find_next_method_by_name_which_is_not_overridden($name);
156 $_super_package = $real_super->package_name;
158 $self->add_method($name => sub {
161 no warnings 'redefine';
162 local *{$_super_package . '::inner'} = sub { $method->(@args) };
163 return $super->(@args);
167 ## Private Utility methods ...
169 sub _find_next_method_by_name_which_is_not_overridden {
170 my ($self, $name) = @_;
171 my @methods = $self->find_all_methods_by_name($name);
172 foreach my $method (@methods) {
173 return $method->{code}
174 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
179 sub _fix_metaclass_incompatability {
180 my ($self, @superclasses) = @_;
181 foreach my $super (@superclasses) {
182 # don't bother if it does not have a meta.
183 next unless $super->can('meta');
184 # if it's meta is a vanilla Moose,
185 # then we can safely ignore it.
186 next if blessed($super->meta) eq 'Moose::Meta::Class';
187 # but if we have anything else,
188 # we need to check it out ...
189 unless (# see if of our metaclass is incompatible
190 ($self->isa(blessed($super->meta)) &&
191 # and see if our instance metaclass is incompatible
192 $self->instance_metaclass->isa($super->meta->instance_metaclass)) &&
193 # ... and if we are just a vanilla Moose
194 $self->isa('Moose::Meta::Class')) {
195 # re-initialize the meta ...
196 my $super_meta = $super->meta;
198 # We might want to consider actually
199 # transfering any attributes from the
200 # original meta into this one, but in
201 # general you should not have any there
202 # at this point anyway, so it's very
203 # much an obscure edge case anyway
204 $self = $super_meta->reinitialize($self->name => (
205 ':attribute_metaclass' => $super_meta->attribute_metaclass,
206 ':method_metaclass' => $super_meta->method_metaclass,
207 ':instance_metaclass' => $super_meta->instance_metaclass,
214 sub _apply_all_roles {
215 my ($self, @roles) = @_;
216 ($_->can('meta') && $_->meta->isa('Moose::Meta::Role'))
217 || confess "You can only consume roles, $_ is not a Moose role"
219 if (scalar @roles == 1) {
220 $roles[0]->meta->apply($self);
223 Moose::Meta::Role->combine(
224 map { $_->meta } @roles
229 sub _process_attribute {
230 my ($self, $name, %options) = @_;
231 if ($name =~ /^\+(.*)/) {
232 my $new_attr = $self->_process_inherited_attribute($1, %options);
233 $self->add_attribute($new_attr);
236 if ($options{metaclass}) {
237 Moose::_load_all_classes($options{metaclass});
238 $self->add_attribute($options{metaclass}->new($name, %options));
241 $self->add_attribute($name, %options);
246 sub _process_inherited_attribute {
247 my ($self, $attr_name, %options) = @_;
248 my $inherited_attr = $self->find_attribute_by_name($attr_name);
249 (defined $inherited_attr)
250 || confess "Could not find an attribute by the name of '$attr_name' to inherit from";
252 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
253 $new_attr = $inherited_attr->clone_and_inherit_options(%options);
257 # kind of a kludge to handle Class::MOP::Attributes
258 $new_attr = Moose::Meta::Attribute::clone_and_inherit_options(
259 $inherited_attr, %options
265 package Moose::Meta::Method::Overriden;
270 our $VERSION = '0.01';
272 use base 'Class::MOP::Method';
282 Moose::Meta::Class - The Moose metaclass
286 This is a subclass of L<Class::MOP::Class> with Moose specific
289 For the most part, the only time you will ever encounter an
290 instance of this class is if you are doing some serious deep
291 introspection. To really understand this class, you need to refer
292 to the L<Class::MOP::Class> documentation.
302 We override this method to support the C<trigger> attribute option.
304 =item B<construct_instance>
306 This provides some Moose specific extensions to this method, you
307 almost never call this method directly unless you really know what
310 This method makes sure to handle the moose weak-ref, type-constraint
311 and type coercion features.
313 =item B<has_method ($name)>
315 This accomidates Moose::Meta::Role::Method instances, which are
316 aliased, instead of added, but still need to be counted as valid
319 =item B<add_override_method_modifier ($name, $method)>
321 This will create an C<override> method modifier for you, and install
324 =item B<add_augment_method_modifier ($name, $method)>
326 This will create an C<augment> method modifier for you, and install
331 This will return an array of C<Moose::Meta::Role> instances which are
332 attached to this class.
334 =item B<add_role ($role)>
336 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
337 to the list of associated roles.
339 =item B<does_role ($role_name)>
341 This will test if this class C<does> a given C<$role_name>. It will
342 not only check it's local roles, but ask them as well in order to
343 cascade down the role hierarchy.
345 =item B<excludes_role ($role_name)>
347 This will test if this class C<excludes> a given C<$role_name>. It will
348 not only check it's local roles, but ask them as well in order to
349 cascade down the role hierarchy.
351 =item B<add_attribute ($attr_name, %params|$params)>
353 This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
354 support for taking the C<$params> as a HASH ref.
360 All complex software has bugs lurking in it, and this module is no
361 exception. If you find a bug please either email me, or add the bug
366 Stevan Little E<lt>stevan@iinteractive.comE<gt>
368 =head1 COPYRIGHT AND LICENSE
370 Copyright 2006 by Infinity Interactive, Inc.
372 L<http://www.iinteractive.com>
374 This library is free software; you can redistribute it and/or modify
375 it under the same terms as Perl itself.