trunk working again
[gitmo/Moose.git] / lib / Moose / Meta / Class.pm
CommitLineData
c0e30cf5 1
2package Moose::Meta::Class;
3
4use strict;
5use warnings;
6
648e79ae 7use Class::MOP;
8
6ba6d68c 9use Carp 'confess';
54b1cdf0 10use Scalar::Util 'weaken', 'blessed', 'reftype';
a15dff8d 11
8453c358 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 {
53dd42d8 204 next if ($pkg || '') ne $class_name &&
205 ($name || '') ne '__ANON__';
206
093b12c2 207 }
ac2dc464 208
093b12c2 209 $map->{$symbol} = $method_metaclass->wrap($code);
210 }
ac2dc464 211
093b12c2 212 return $map;
a7d0cd00 213}
214
093b12c2 215### ---------------------------------------------
216
a2eec5e7 217sub add_attribute {
218 my $self = shift;
e472c9a5 219 $self->SUPER::add_attribute(
220 (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
221 ? $_[0]
222 : $self->_process_attribute(@_))
223 );
a2eec5e7 224}
225
78cd1d3b 226sub add_override_method_modifier {
227 my ($self, $name, $method, $_super_package) = @_;
18c2ec0e 228
d05cd563 229 (!$self->has_method($name))
230 || confess "Cannot add an override method if a local method is already present";
18c2ec0e 231
232 $self->add_method($name => Moose::Meta::Method::Overriden->new(
3f9e4b0a 233 method => $method,
234 class => $self,
235 package => $_super_package, # need this for roles
236 name => $name,
18c2ec0e 237 ));
78cd1d3b 238}
239
240sub add_augment_method_modifier {
ac2dc464 241 my ($self, $name, $method) = @_;
d05cd563 242 (!$self->has_method($name))
ac2dc464 243 || confess "Cannot add an augment method if a local method is already present";
3f9e4b0a 244
245 $self->add_method($name => Moose::Meta::Method::Augmented->new(
246 method => $method,
247 class => $self,
248 name => $name,
249 ));
78cd1d3b 250}
251
1341f10c 252## Private Utility methods ...
253
05d9eaf6 254sub _find_next_method_by_name_which_is_not_overridden {
255 my ($self, $name) = @_;
68efb014 256 foreach my $method ($self->find_all_methods_by_name($name)) {
ac2dc464 257 return $method->{code}
05d9eaf6 258 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
259 }
260 return undef;
261}
262
1341f10c 263sub _fix_metaclass_incompatability {
264 my ($self, @superclasses) = @_;
265 foreach my $super (@superclasses) {
266 # don't bother if it does not have a meta.
267 next unless $super->can('meta');
ac2dc464 268 # get the name, make sure we take
8ecb1fa0 269 # immutable classes into account
ac2dc464 270 my $super_meta_name = ($super->meta->is_immutable
8ecb1fa0 271 ? $super->meta->get_mutable_metaclass_name
272 : blessed($super->meta));
ac2dc464 273 # if it's meta is a vanilla Moose,
274 # then we can safely ignore it.
8ecb1fa0 275 next if $super_meta_name eq 'Moose::Meta::Class';
ac2dc464 276 # but if we have anything else,
1341f10c 277 # we need to check it out ...
278 unless (# see if of our metaclass is incompatible
8ecb1fa0 279 ($self->isa($super_meta_name) &&
1341f10c 280 # and see if our instance metaclass is incompatible
281 $self->instance_metaclass->isa($super->meta->instance_metaclass)) &&
282 # ... and if we are just a vanilla Moose
283 $self->isa('Moose::Meta::Class')) {
284 # re-initialize the meta ...
285 my $super_meta = $super->meta;
286 # NOTE:
ac2dc464 287 # We might want to consider actually
288 # transfering any attributes from the
289 # original meta into this one, but in
1341f10c 290 # general you should not have any there
ac2dc464 291 # at this point anyway, so it's very
1341f10c 292 # much an obscure edge case anyway
293 $self = $super_meta->reinitialize($self->name => (
ac2dc464 294 'attribute_metaclass' => $super_meta->attribute_metaclass,
5cf3dbcf 295 'method_metaclass' => $super_meta->method_metaclass,
296 'instance_metaclass' => $super_meta->instance_metaclass,
1341f10c 297 ));
298 }
299 }
ac2dc464 300 return $self;
1341f10c 301}
302
d7d8a8c7 303# NOTE:
d9bb6c63 304# this was crap anyway, see
305# Moose::Util::apply_all_roles
d7d8a8c7 306# instead
4498537c 307sub _apply_all_roles {
547dda77 308 Carp::croak 'DEPRECATED: use Moose::Util::apply_all_roles($meta, @roles) instead'
4498537c 309}
1341f10c 310
311sub _process_attribute {
a3738e5b 312 my ( $self, $name, @args ) = @_;
7e59b803 313
314 @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH';
d9bb6c63 315
1341f10c 316 if ($name =~ /^\+(.*)/) {
7e59b803 317 return $self->_process_inherited_attribute($1, @args);
1341f10c 318 }
319 else {
7e59b803 320 return $self->_process_new_attribute($name, @args);
321 }
322}
323
324sub _process_new_attribute {
325 my ( $self, $name, @args ) = @_;
7e59b803 326
d5c30e52 327 $self->attribute_metaclass->interpolate_class_and_new($name, @args);
1341f10c 328}
329
330sub _process_inherited_attribute {
331 my ($self, $attr_name, %options) = @_;
332 my $inherited_attr = $self->find_attribute_by_name($attr_name);
333 (defined $inherited_attr)
334 || confess "Could not find an attribute by the name of '$attr_name' to inherit from";
1341f10c 335 if ($inherited_attr->isa('Moose::Meta::Attribute')) {
d7d8a8c7 336 return $inherited_attr->clone_and_inherit_options(%options);
1341f10c 337 }
338 else {
339 # NOTE:
340 # kind of a kludge to handle Class::MOP::Attributes
d7d8a8c7 341 return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options);
ac2dc464 342 }
1341f10c 343}
344
5cf3dbcf 345## -------------------------------------------------
346
347use Moose::Meta::Method::Constructor;
1f779926 348use Moose::Meta::Method::Destructor;
5cf3dbcf 349
ac2dc464 350# This could be done by using SUPER and altering ->options
351# I am keeping it this way to make it more explicit.
352sub create_immutable_transformer {
353 my $self = shift;
354 my $class = Class::MOP::Immutable->new($self, {
355 read_only => [qw/superclasses/],
356 cannot_call => [qw/
357 add_method
358 alias_method
359 remove_method
360 add_attribute
361 remove_attribute
ac2dc464 362 remove_package_symbol
363 add_role
364 /],
365 memoize => {
366 class_precedence_list => 'ARRAY',
367 compute_all_applicable_attributes => 'ARRAY',
368 get_meta_instance => 'SCALAR',
369 get_method_map => 'SCALAR',
370 # maybe ....
371 calculate_all_roles => 'ARRAY',
8453c358 372 },
373 # NOTE:
374 # this is ugly, but so are typeglobs,
375 # so whattayahgonnadoboutit
376 # - SL
377 wrapped => {
378 add_package_symbol => sub {
379 my $original = shift;
380 confess "Cannot add package symbols to an immutable metaclass"
381 unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol';
382 goto $original->body;
383 },
384 },
ac2dc464 385 });
386 return $class;
387}
388
389sub make_immutable {
390 my $self = shift;
391 $self->SUPER::make_immutable
392 (
393 constructor_class => 'Moose::Meta::Method::Constructor',
394 destructor_class => 'Moose::Meta::Method::Destructor',
395 inline_destructor => 1,
396 # NOTE:
397 # no need to do this,
398 # Moose always does it
399 inline_accessors => 0,
400 @_,
401 );
5cf3dbcf 402}
403
c0e30cf5 4041;
405
406__END__
407
408=pod
409
410=head1 NAME
411
e522431d 412Moose::Meta::Class - The Moose metaclass
c0e30cf5 413
c0e30cf5 414=head1 DESCRIPTION
415
ac2dc464 416This is a subclass of L<Class::MOP::Class> with Moose specific
e522431d 417extensions.
418
ac2dc464 419For the most part, the only time you will ever encounter an
420instance of this class is if you are doing some serious deep
421introspection. To really understand this class, you need to refer
6ba6d68c 422to the L<Class::MOP::Class> documentation.
423
c0e30cf5 424=head1 METHODS
425
426=over 4
427
590868a3 428=item B<initialize>
429
61bdd94f 430=item B<create>
431
17594769 432Overrides original to accept a list of roles to apply to
61bdd94f 433the created class.
434
17594769 435 my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] );
436
437=item B<create_anon_class>
438
439Overrides original to support roles and caching.
440
441 my $metaclass = Moose::Meta::Class->create_anon_class(
442 superclasses => ['Foo'],
443 roles => [qw/Some Roles Go Here/],
444 cache => 1,
445 );
446
5cf3dbcf 447=item B<make_immutable>
448
ac2dc464 449Override original to add default options for inlining destructor
450and altering the Constructor metaclass.
451
452=item B<create_immutable_transformer>
453
454Override original to lock C<add_role> and memoize C<calculate_all_roles>
455
8c9d74e7 456=item B<new_object>
457
02a0fb52 458We override this method to support the C<trigger> attribute option.
459
a15dff8d 460=item B<construct_instance>
461
ac2dc464 462This provides some Moose specific extensions to this method, you
463almost never call this method directly unless you really know what
464you are doing.
6ba6d68c 465
466This method makes sure to handle the moose weak-ref, type-constraint
ac2dc464 467and type coercion features.
ef1d5f4b 468
093b12c2 469=item B<get_method_map>
e9ec68d6 470
ac2dc464 471This accommodates Moose::Meta::Role::Method instances, which are
472aliased, instead of added, but still need to be counted as valid
e9ec68d6 473methods.
474
78cd1d3b 475=item B<add_override_method_modifier ($name, $method)>
476
ac2dc464 477This will create an C<override> method modifier for you, and install
02a0fb52 478it in the package.
479
78cd1d3b 480=item B<add_augment_method_modifier ($name, $method)>
481
ac2dc464 482This will create an C<augment> method modifier for you, and install
02a0fb52 483it in the package.
484
2b14ac61 485=item B<calculate_all_roles>
486
ef333f17 487=item B<roles>
488
ac2dc464 489This will return an array of C<Moose::Meta::Role> instances which are
02a0fb52 490attached to this class.
491
ef333f17 492=item B<add_role ($role)>
493
ac2dc464 494This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
02a0fb52 495to the list of associated roles.
496
ef333f17 497=item B<does_role ($role_name)>
498
ac2dc464 499This will test if this class C<does> a given C<$role_name>. It will
500not only check it's local roles, but ask them as well in order to
02a0fb52 501cascade down the role hierarchy.
502
d79e62fd 503=item B<excludes_role ($role_name)>
504
ac2dc464 505This will test if this class C<excludes> a given C<$role_name>. It will
506not only check it's local roles, but ask them as well in order to
d79e62fd 507cascade down the role hierarchy.
508
9e93dd19 509=item B<add_attribute ($attr_name, %params|$params)>
4e848edb 510
9e93dd19 511This method does the same thing as L<Class::MOP::Class::add_attribute>, but adds
512support for taking the C<$params> as a HASH ref.
ac1ef2f9 513
c0e30cf5 514=back
515
516=head1 BUGS
517
ac2dc464 518All complex software has bugs lurking in it, and this module is no
c0e30cf5 519exception. If you find a bug please either email me, or add the bug
520to cpan-RT.
521
c0e30cf5 522=head1 AUTHOR
523
524Stevan Little E<lt>stevan@iinteractive.comE<gt>
525
526=head1 COPYRIGHT AND LICENSE
527
778db3ac 528Copyright 2006-2008 by Infinity Interactive, Inc.
c0e30cf5 529
530L<http://www.iinteractive.com>
531
532This library is free software; you can redistribute it and/or modify
ac2dc464 533it under the same terms as Perl itself.
c0e30cf5 534
8a7a9c53 535=cut
1a563243 536