0.45
[gitmo/Moose.git] / lib / Moose / Meta / Class.pm
CommitLineData
c0e30cf5 1
2package Moose::Meta::Class;
3
4use strict;
5use warnings;
6
1b2aea39 7use Class::MOP 0.56;
648e79ae 8
6ba6d68c 9use Carp 'confess';
54b1cdf0 10use Scalar::Util 'weaken', 'blessed', 'reftype';
a15dff8d 11
c998012c 12our $VERSION = '0.22';
d44714be 13our $AUTHORITY = 'cpan:STEVAN';
bc1e29b5 14
8ee73eeb 15use Moose::Meta::Method::Overriden;
3f9e4b0a 16use Moose::Meta::Method::Augmented;
8ee73eeb 17
c0e30cf5 18use base 'Class::MOP::Class';
19
598340d5 20__PACKAGE__->meta->add_attribute('roles' => (
ef333f17 21 reader => 'roles',
22 default => sub { [] }
23));
24
590868a3 25sub initialize {
26 my $class = shift;
27 my $pkg = shift;
28 $class->SUPER::initialize($pkg,
ac2dc464 29 'attribute_metaclass' => 'Moose::Meta::Attribute',
5cf3dbcf 30 'method_metaclass' => 'Moose::Meta::Method',
ac2dc464 31 'instance_metaclass' => 'Moose::Meta::Instance',
590868a3 32 @_);
ac2dc464 33}
590868a3 34
61bdd94f 35sub create {
36 my ($self, $package_name, %options) = @_;
37
38 (ref $options{roles} eq 'ARRAY')
39 || confess "You must pass an ARRAY ref of roles"
40 if exists $options{roles};
41
42 my $class = $self->SUPER::create($package_name, %options);
43
48045612 44 if (exists $options{roles}) {
61bdd94f 45 Moose::Util::apply_all_roles($class, @{$options{roles}});
46 }
47
48 return $class;
49}
50
17594769 51my %ANON_CLASSES;
52
53sub create_anon_class {
54 my ($self, %options) = @_;
55
56 my $cache_ok = delete $options{cache};
17594769 57
58 # something like Super::Class|Super::Class::2=Role|Role::1
59 my $cache_key = join '=' => (
6d5cbd2b 60 join('|', sort @{$options{superclasses} || []}),
61 join('|', sort @{$options{roles} || []}),
17594769 62 );
63
6d5cbd2b 64 if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
17594769 65 return $ANON_CLASSES{$cache_key};
66 }
67
68 my $new_class = $self->SUPER::create_anon_class(%options);
69
6d5cbd2b 70 $ANON_CLASSES{$cache_key} = $new_class
71 if $cache_ok;
17594769 72
73 return $new_class;
74}
75
ef333f17 76sub add_role {
77 my ($self, $role) = @_;
78 (blessed($role) && $role->isa('Moose::Meta::Role'))
79 || confess "Roles must be instances of Moose::Meta::Role";
80 push @{$self->roles} => $role;
81}
82
b8aeb4dc 83sub calculate_all_roles {
84 my $self = shift;
85 my %seen;
86 grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles };
87}
88
ef333f17 89sub does_role {
90 my ($self, $role_name) = @_;
91 (defined $role_name)
92 || confess "You must supply a role name to look for";
9c429218 93 foreach my $class ($self->class_precedence_list) {
81c3738f 94 next unless $class->can('meta') && $class->meta->can('roles');
9c429218 95 foreach my $role (@{$class->meta->roles}) {
96 return 1 if $role->does_role($role_name);
97 }
ef333f17 98 }
99 return 0;
100}
101
d79e62fd 102sub excludes_role {
103 my ($self, $role_name) = @_;
104 (defined $role_name)
105 || confess "You must supply a role name to look for";
ac2dc464 106 foreach my $class ($self->class_precedence_list) {
107 next unless $class->can('meta');
5cb193ed 108 # NOTE:
109 # in the pretty rare instance when a Moose metaclass
ac2dc464 110 # is itself extended with a role, this check needs to
5cb193ed 111 # be done since some items in the class_precedence_list
ac2dc464 112 # might in fact be Class::MOP based still.
113 next unless $class->meta->can('roles');
9c429218 114 foreach my $role (@{$class->meta->roles}) {
115 return 1 if $role->excludes_role($role_name);
116 }
d79e62fd 117 }
118 return 0;
119}
120
8c9d74e7 121sub new_object {
122 my ($class, %params) = @_;
123 my $self = $class->SUPER::new_object(%params);
124 foreach my $attr ($class->compute_all_applicable_attributes()) {
4078709c 125 # if we have a trigger, then ...
126 if ($attr->can('has_trigger') && $attr->has_trigger) {
127 # make sure we have an init-arg ...
128 if (defined(my $init_arg = $attr->init_arg)) {
129 # now make sure an init-arg was passes ...
130 if (exists $params{$init_arg}) {
131 # and if get here, fire the trigger
132 $attr->trigger->(
133 $self,
134 # check if there is a coercion
135 ($attr->should_coerce
136 # and if so, we need to grab the
137 # value that is actually been stored
138 ? $attr->get_read_method_ref->($self)
139 # otherwise, just get the value from
140 # the constructor params
141 : $params{$init_arg}),
142 $attr
143 );
144 }
145 }
625d571f 146 }
8c9d74e7 147 }
ac2dc464 148 return $self;
8c9d74e7 149}
150
a15dff8d 151sub construct_instance {
152 my ($class, %params) = @_;
ddd0ec20 153 my $meta_instance = $class->get_meta_instance;
575db57d 154 # FIXME:
155 # the code below is almost certainly incorrect
156 # but this is foreign inheritence, so we might
ac2dc464 157 # have to kludge it in the end.
ddd0ec20 158 my $instance = $params{'__INSTANCE__'} || $meta_instance->create_instance();
ac2dc464 159 foreach my $attr ($class->compute_all_applicable_attributes()) {
c32c2c61 160 $attr->initialize_instance_slot($meta_instance, $instance, \%params);
a15dff8d 161 }
162 return $instance;
163}
164
093b12c2 165# FIXME:
166# This is ugly
ac2dc464 167sub get_method_map {
093b12c2 168 my $self = shift;
53dd42d8 169
170 if (defined $self->{'$!_package_cache_flag'} &&
66e08a8a 171 $self->{'$!_package_cache_flag'} == Class::MOP::check_package_cache_flag($self->meta->name)) {
53dd42d8 172 return $self->{'%!methods'};
173 }
174
ac2dc464 175 my $map = $self->{'%!methods'};
176
093b12c2 177 my $class_name = $self->name;
178 my $method_metaclass = $self->method_metaclass;
ac2dc464 179
093b12c2 180 foreach my $symbol ($self->list_all_package_symbols('CODE')) {
ac2dc464 181
093b12c2 182 my $code = $self->get_package_symbol('&' . $symbol);
ac2dc464 183
184 next if exists $map->{$symbol} &&
185 defined $map->{$symbol} &&
186 $map->{$symbol}->body == $code;
187
53dd42d8 188 my ($pkg, $name) = Class::MOP::get_code_info($code);
ac2dc464 189
53dd42d8 190 if ($pkg->can('meta')
4f8f3aab 191 # NOTE:
192 # we don't know what ->meta we are calling
53dd42d8 193 # here, so we need to be careful cause it
194 # just might blow up at us, or just complain
195 # loudly (in the case of Curses.pm) so we
4f8f3aab 196 # just be a little overly cautious here.
197 # - SL
198 && eval { no warnings; blessed($pkg->meta) }
199 && $pkg->meta->isa('Moose::Meta::Role')) {
093b12c2 200 #my $role = $pkg->meta->name;
201 #next unless $self->does_role($role);
202 }
203 else {
2887c827 204
205 # NOTE:
206 # in 5.10 constant.pm the constants show up
207 # as being in the right package, but in pre-5.10
208 # they show up as constant::__ANON__ so we
209 # make an exception here to be sure that things
210 # work as expected in both.
211 # - SL
212 unless ($pkg eq 'constant' && $name eq '__ANON__') {
213 next if ($pkg || '') ne $class_name ||
214 (($name || '') ne '__ANON__' && ($pkg || '') ne $class_name);
215 }
53dd42d8 216
093b12c2 217 }
ac2dc464 218
1b2aea39 219 $map->{$symbol} = $method_metaclass->wrap(
220 $code,
221 package_name => $class_name,
222 name => $symbol
223 );
093b12c2 224 }
ac2dc464 225
093b12c2 226 return $map;
a7d0cd00 227}
228
093b12c2 229### ---------------------------------------------
230
a2eec5e7 231sub add_attribute {
232 my $self = shift;
e472c9a5 233 $self->SUPER::add_attribute(
234 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
235 ? $_[0]
236 : $self->_process_attribute(@_))
237 );
a2eec5e7 238}
239
78cd1d3b 240sub add_override_method_modifier {
241 my ($self, $name, $method, $_super_package) = @_;
18c2ec0e 242
d05cd563 243 (!$self->has_method($name))
244 || confess "Cannot add an override method if a local method is already present";
18c2ec0e 245
246 $self->add_method($name => Moose::Meta::Method::Overriden->new(
3f9e4b0a 247 method => $method,
248 class => $self,
249 package => $_super_package, # need this for roles
250 name => $name,
18c2ec0e 251 ));
78cd1d3b 252}
253
254sub add_augment_method_modifier {
ac2dc464 255 my ($self, $name, $method) = @_;
d05cd563 256 (!$self->has_method($name))
ac2dc464 257 || confess "Cannot add an augment method if a local method is already present";
3f9e4b0a 258
259 $self->add_method($name => Moose::Meta::Method::Augmented->new(
260 method => $method,
261 class => $self,
262 name => $name,
263 ));
78cd1d3b 264}
265
1341f10c 266## Private Utility methods ...
267
05d9eaf6 268sub _find_next_method_by_name_which_is_not_overridden {
269 my ($self, $name) = @_;
68efb014 270 foreach my $method ($self->find_all_methods_by_name($name)) {
ac2dc464 271 return $method->{code}
05d9eaf6 272 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
273 }
274 return undef;
275}
276
1341f10c 277sub _fix_metaclass_incompatability {
278 my ($self, @superclasses) = @_;
279 foreach my $super (@superclasses) {
280 # don't bother if it does not have a meta.
281 next unless $super->can('meta');
ac2dc464 282 # get the name, make sure we take
8ecb1fa0 283 # immutable classes into account
ac2dc464 284 my $super_meta_name = ($super->meta->is_immutable
8ecb1fa0 285 ? $super->meta->get_mutable_metaclass_name
286 : blessed($super->meta));
ac2dc464 287 # if it's meta is a vanilla Moose,
288 # then we can safely ignore it.
8ecb1fa0 289 next if $super_meta_name eq 'Moose::Meta::Class';
ac2dc464 290 # but if we have anything else,
1341f10c 291 # we need to check it out ...
292 unless (# see if of our metaclass is incompatible
8ecb1fa0 293 ($self->isa($super_meta_name) &&
1341f10c 294 # and see if our instance metaclass is incompatible
295 $self->instance_metaclass->isa($super->meta->instance_metaclass)) &&
296 # ... and if we are just a vanilla Moose
297 $self->isa('Moose::Meta::Class')) {
298 # re-initialize the meta ...
299 my $super_meta = $super->meta;
300 # NOTE:
ac2dc464 301 # We might want to consider actually
302 # transfering any attributes from the
303 # original meta into this one, but in
1341f10c 304 # general you should not have any there
ac2dc464 305 # at this point anyway, so it's very
1341f10c 306 # much an obscure edge case anyway
307 $self = $super_meta->reinitialize($self->name => (
ac2dc464 308 'attribute_metaclass' => $super_meta->attribute_metaclass,
5cf3dbcf 309 'method_metaclass' => $super_meta->method_metaclass,
310 'instance_metaclass' => $super_meta->instance_metaclass,
1341f10c 311 ));
312 }
313 }
ac2dc464 314 return $self;
1341f10c 315}
316
d7d8a8c7 317# NOTE:
d9bb6c63 318# this was crap anyway, see
319# Moose::Util::apply_all_roles
d7d8a8c7 320# instead
4498537c 321sub _apply_all_roles {
547dda77 322 Carp::croak 'DEPRECATED: use Moose::Util::apply_all_roles($meta, @roles) instead'
4498537c 323}
1341f10c 324
325sub _process_attribute {
a3738e5b 326 my ( $self, $name, @args ) = @_;
7e59b803 327
328 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
d9bb6c63 329
1341f10c 330 if ($name =~ /^\+(.*)/) {
7e59b803 331 return $self->_process_inherited_attribute($1, @args);
1341f10c 332 }
333 else {
7e59b803 334 return $self->_process_new_attribute($name, @args);
335 }
336}
337
338sub _process_new_attribute {
339 my ( $self, $name, @args ) = @_;
7e59b803 340
d5c30e52 341 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
1341f10c 342}
343
344sub _process_inherited_attribute {
345 my ($self, $attr_name, %options) = @_;
346 my $inherited_attr = $self->find_attribute_by_name($attr_name);
347 (defined $inherited_attr)
348 || confess "Could not find an attribute by the name of '$attr_name' to inherit from";
1341f10c 349 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
d7d8a8c7 350 return $inherited_attr->clone_and_inherit_options(%options);
1341f10c 351 }
352 else {
353 # NOTE:
354 # kind of a kludge to handle Class::MOP::Attributes
d7d8a8c7 355 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
ac2dc464 356 }
1341f10c 357}
358
5cf3dbcf 359## -------------------------------------------------
360
361use Moose::Meta::Method::Constructor;
1f779926 362use Moose::Meta::Method::Destructor;
5cf3dbcf 363
ac2dc464 364# This could be done by using SUPER and altering ->options
365# I am keeping it this way to make it more explicit.
366sub create_immutable_transformer {
367 my $self = shift;
368 my $class = Class::MOP::Immutable->new($self, {
369 read_only => [qw/superclasses/],
370 cannot_call => [qw/
371 add_method
372 alias_method
373 remove_method
374 add_attribute
375 remove_attribute
ac2dc464 376 remove_package_symbol
377 add_role
378 /],
379 memoize => {
380 class_precedence_list => 'ARRAY',
381 compute_all_applicable_attributes => 'ARRAY',
382 get_meta_instance => 'SCALAR',
383 get_method_map => 'SCALAR',
384 # maybe ....
385 calculate_all_roles => 'ARRAY',
8453c358 386 },
387 # NOTE:
388 # this is ugly, but so are typeglobs,
389 # so whattayahgonnadoboutit
390 # - SL
391 wrapped => {
392 add_package_symbol => sub {
393 my $original = shift;
394 confess "Cannot add package symbols to an immutable metaclass"
395 unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol';
396 goto $original->body;
397 },
398 },
ac2dc464 399 });
400 return $class;
401}
402
403sub make_immutable {
404 my $self = shift;
405 $self->SUPER::make_immutable
406 (
407 constructor_class => 'Moose::Meta::Method::Constructor',
408 destructor_class => 'Moose::Meta::Method::Destructor',
409 inline_destructor => 1,
410 # NOTE:
411 # no need to do this,
412 # Moose always does it
413 inline_accessors => 0,
414 @_,
415 );
5cf3dbcf 416}
417
c0e30cf5 4181;
419
420__END__
421
422=pod
423
424=head1 NAME
425
e522431d 426Moose::Meta::Class - The Moose metaclass
c0e30cf5 427
c0e30cf5 428=head1 DESCRIPTION
429
ac2dc464 430This is a subclass of L<Class::MOP::Class> with Moose specific
e522431d 431extensions.
432
ac2dc464 433For the most part, the only time you will ever encounter an
434instance of this class is if you are doing some serious deep
435introspection. To really understand this class, you need to refer
6ba6d68c 436to the L<Class::MOP::Class> documentation.
437
c0e30cf5 438=head1 METHODS
439
440=over 4
441
590868a3 442=item B<initialize>
443
61bdd94f 444=item B<create>
445
17594769 446Overrides original to accept a list of roles to apply to
61bdd94f 447the created class.
448
17594769 449 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
450
451=item B<create_anon_class>
452
453Overrides original to support roles and caching.
454
455 my $metaclass = Moose::Meta::Class->create_anon_class(
456 superclasses => ['Foo'],
457 roles => [qw/Some Roles Go Here/],
458 cache => 1,
459 );
460
5cf3dbcf 461=item B<make_immutable>
462
ac2dc464 463Override original to add default options for inlining destructor
464and altering the Constructor metaclass.
465
466=item B<create_immutable_transformer>
467
468Override original to lock C<add_role> and memoize C<calculate_all_roles>
469
8c9d74e7 470=item B<new_object>
471
02a0fb52 472We override this method to support the C<trigger> attribute option.
473
a15dff8d 474=item B<construct_instance>
475
ac2dc464 476This provides some Moose specific extensions to this method, you
477almost never call this method directly unless you really know what
478you are doing.
6ba6d68c 479
480This method makes sure to handle the moose weak-ref, type-constraint
ac2dc464 481and type coercion features.
ef1d5f4b 482
093b12c2 483=item B<get_method_map>
e9ec68d6 484
ac2dc464 485This accommodates Moose::Meta::Role::Method instances, which are
486aliased, instead of added, but still need to be counted as valid
e9ec68d6 487methods.
488
78cd1d3b 489=item B<add_override_method_modifier ($name, $method)>
490
ac2dc464 491This will create an C<override> method modifier for you, and install
02a0fb52 492it in the package.
493
78cd1d3b 494=item B<add_augment_method_modifier ($name, $method)>
495
ac2dc464 496This will create an C<augment> method modifier for you, and install
02a0fb52 497it in the package.
498
2b14ac61 499=item B<calculate_all_roles>
500
ef333f17 501=item B<roles>
502
ac2dc464 503This will return an array of C<Moose::Meta::Role> instances which are
02a0fb52 504attached to this class.
505
ef333f17 506=item B<add_role ($role)>
507
ac2dc464 508This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
02a0fb52 509to the list of associated roles.
510
ef333f17 511=item B<does_role ($role_name)>
512
ac2dc464 513This will test if this class C<does> a given C<$role_name>. It will
514not only check it's local roles, but ask them as well in order to
02a0fb52 515cascade down the role hierarchy.
516
d79e62fd 517=item B<excludes_role ($role_name)>
518
ac2dc464 519This will test if this class C<excludes> a given C<$role_name>. It will
520not only check it's local roles, but ask them as well in order to
d79e62fd 521cascade down the role hierarchy.
522
9e93dd19 523=item B<add_attribute ($attr_name, %params|$params)>
4e848edb 524
9e93dd19 525This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
526support for taking the C<$params> as a HASH ref.
ac1ef2f9 527
c0e30cf5 528=back
529
530=head1 BUGS
531
ac2dc464 532All complex software has bugs lurking in it, and this module is no
c0e30cf5 533exception. If you find a bug please either email me, or add the bug
534to cpan-RT.
535
c0e30cf5 536=head1 AUTHOR
537
538Stevan Little E<lt>stevan@iinteractive.comE<gt>
539
540=head1 COPYRIGHT AND LICENSE
541
778db3ac 542Copyright 2006-2008 by Infinity Interactive, Inc.
c0e30cf5 543
544L<http://www.iinteractive.com>
545
546This library is free software; you can redistribute it and/or modify
ac2dc464 547it under the same terms as Perl itself.
c0e30cf5 548
8a7a9c53 549=cut
1a563243 550