2 package Moose::Meta::Class;
10 use Scalar::Util 'weaken', 'blessed', 'reftype';
12 our $VERSION = '0.05';
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 $role (@{$self->roles}) {
42 return 1 if $role->does_role($role_name);
48 my ($class, %params) = @_;
49 my $self = $class->SUPER::new_object(%params);
50 foreach my $attr ($class->compute_all_applicable_attributes()) {
51 next unless $params{$attr->init_arg} && $attr->can('has_trigger') && $attr->has_trigger;
52 $attr->trigger->($self, $params{$attr->init_arg}, $attr);
57 sub construct_instance {
58 my ($class, %params) = @_;
59 my $meta_instance = $class->get_meta_instance;
60 my $instance = $params{'__INSTANCE__'} || $meta_instance->create_instance();
61 foreach my $attr ($class->compute_all_applicable_attributes()) {
62 $attr->initialize_instance_slot($meta_instance, $instance, \%params)
68 my ($self, $method_name) = @_;
69 (defined $method_name && $method_name)
70 || confess "You must define a method name";
72 my $sub_name = ($self->name . '::' . $method_name);
75 return 0 if !defined(&{$sub_name});
76 my $method = \&{$sub_name};
78 return 1 if blessed($method) && $method->isa('Moose::Meta::Role::Method');
79 return $self->SUPER::has_method($method_name);
83 my ($self, $name, %params) = @_;
86 if ( my $delegation = delete $params{handles} ) {
87 my @method_names_or_hashes = $self->compute_delegation( $name, $delegation, \%params );
88 @delegations = $self->get_delegatable_methods( @method_names_or_hashes );
91 my $ret = $self->SUPER::add_attribute( $name, %params );
94 my $attr = $self->get_attribute( $name );
95 $self->generate_delgate_method( $attr, $_ ) for $self->filter_delegations( $attr, @delegations );
101 sub filter_delegations {
102 my ( $self, $attr, @delegations ) = @_;
104 my $new_name = $_->{new_name} || $_->{name};
105 no warnings "uninitialized";
106 !$self->name->can( $new_name ) and
107 $attr->accessor ne $new_name and
108 $attr->reader ne $new_name and
109 $attr->writer ne $new_name
113 sub generate_delgate_method {
114 my ( $self, $attr, $method ) = @_;
116 # FIXME like generated accessors these methods must be regenerated
117 # FIXME the reader may not work for subclasses with weird instances
119 my $make = $method->{generator} || sub {
120 my ( $self, $attr, $method ) =@_;
122 my $method_name = $method->{name};
123 my $reader = $attr->generate_reader_method();
126 if ( Scalar::Util::blessed( my $delegate = shift->$reader ) ) {
127 return $delegate->$method_name( @_ );
133 my $new_name = $method->{new_name} || $method->{name};
134 $self->add_method( $new_name, $make->( $self, $attr, $method ) );
137 sub compute_delegation {
138 my ( $self, $attr_name, $delegation, $params ) = @_;
141 # either it's a concrete list of method names
142 return $delegation unless ref $delegation; # single method name
143 return @$delegation if reftype($delegation) eq "ARRAY";
145 # or it's a generative api
146 my $delegator_meta = $self->_guess_attr_class_or_role( $attr_name, $params );
147 $self->generate_delegation_list( $delegation, $delegator_meta );
150 sub get_delegatable_methods {
151 my ( $self, @names_or_hashes ) = @_;
152 map { ref($_) ? $_ : { name => $_ } } @names_or_hashes;
155 sub generate_delegation_list {
156 my ( $self, $delegation, $delegator_meta ) = @_;
158 if ( reftype($delegation) eq "CODE" ) {
159 return $delegation->( $self, $delegator_meta );
160 } elsif ( blessed($delegation) eq "Regexp" ) {
161 confess "For regular expression support the delegator class/role must use a Class::MOP::Class metaclass"
162 unless $delegator_meta->isa( "Class::MOP::Class" );
163 return grep { $_->{name} =~ /$delegation/ } $delegator_meta->compute_all_applicable_methods();
165 confess "The 'handles' specification '$delegation' is not supported";
169 sub _guess_attr_class_or_role {
170 my ( $self, $attr, $params ) = @_;
172 my ( $isa, $does ) = @{ $params }{qw/isa does/};
174 confess "Generative delegations must explicitly specify a class or a role for the attribute's type"
175 unless $isa || $does;
177 for (grep { blessed($_) } $isa, $does) {
178 confess "You must use classes/roles, not type constraints to use delegation ($_)"
179 unless $_->isa( "Moose::Meta::Class" );
182 confess "Cannot have an isa option and a does option if the isa does not do the does"
183 if $isa and $does and $isa->can("does") and !$isa->does( $does );
185 # if it's a class/role name make it into a meta object
187 $_ = $_->meta if defined and !ref and $_->can("meta");
190 $isa = Class::MOP::Class->initialize($isa) if $isa and !ref($isa);
192 return $isa || $does;
195 sub add_override_method_modifier {
196 my ($self, $name, $method, $_super_package) = @_;
197 # need this for roles ...
198 $_super_package ||= $self->name;
199 my $super = $self->find_next_method_by_name($name);
201 || confess "You cannot override '$name' because it has no super method";
202 $self->add_method($name => bless sub {
205 no warnings 'redefine';
206 local *{$_super_package . '::super'} = sub { $super->(@args) };
207 return $method->(@args);
208 } => 'Moose::Meta::Method::Overriden');
211 sub add_augment_method_modifier {
212 my ($self, $name, $method) = @_;
213 my $super = $self->find_next_method_by_name($name);
215 || confess "You cannot augment '$name' because it has no super method";
216 my $_super_package = $super->package_name;
217 # BUT!,... if this is an overriden method ....
218 if ($super->isa('Moose::Meta::Method::Overriden')) {
219 # we need to be sure that we actually
220 # find the next method, which is not
221 # an 'override' method, the reason is
222 # that an 'override' method will not
223 # be the one calling inner()
224 my $real_super = $self->_find_next_method_by_name_which_is_not_overridden($name);
225 $_super_package = $real_super->package_name;
227 $self->add_method($name => sub {
230 no warnings 'redefine';
231 local *{$_super_package . '::inner'} = sub { $method->(@args) };
232 return $super->(@args);
236 sub _find_next_method_by_name_which_is_not_overridden {
237 my ($self, $name) = @_;
238 my @methods = $self->find_all_methods_by_name($name);
239 foreach my $method (@methods) {
240 return $method->{code}
241 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
246 package Moose::Meta::Method::Overriden;
251 our $VERSION = '0.01';
253 use base 'Class::MOP::Method';
263 Moose::Meta::Class - The Moose metaclass
267 This is a subclass of L<Class::MOP::Class> with Moose specific
270 For the most part, the only time you will ever encounter an
271 instance of this class is if you are doing some serious deep
272 introspection. To really understand this class, you need to refer
273 to the L<Class::MOP::Class> documentation.
283 We override this method to support the C<trigger> attribute option.
285 =item B<construct_instance>
287 This provides some Moose specific extensions to this method, you
288 almost never call this method directly unless you really know what
291 This method makes sure to handle the moose weak-ref, type-constraint
292 and type coercion features.
294 =item B<has_method ($name)>
296 This accomidates Moose::Meta::Role::Method instances, which are
297 aliased, instead of added, but still need to be counted as valid
300 =item B<add_override_method_modifier ($name, $method)>
302 This will create an C<override> method modifier for you, and install
305 =item B<add_augment_method_modifier ($name, $method)>
307 This will create an C<augment> method modifier for you, and install
312 This will return an array of C<Moose::Meta::Role> instances which are
313 attached to this class.
315 =item B<add_role ($role)>
317 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
318 to the list of associated roles.
320 =item B<does_role ($role_name)>
322 This will test if this class C<does> a given C<$role_name>. It will
323 not only check it's local roles, but ask them as well in order to
324 cascade down the role hierarchy.
326 =item B<add_attribute $attr_name, %params>
328 This method does the same thing as L<Class::MOP::Class/add_attribute>, but adds
329 suport for delegation.
333 =head1 INTERNAL METHODS
337 =item compute_delegation
339 =item generate_delegation_list
341 =item generate_delgate_method
343 =item get_delegatable_methods
349 All complex software has bugs lurking in it, and this module is no
350 exception. If you find a bug please either email me, or add the bug
355 Stevan Little E<lt>stevan@iinteractive.comE<gt>
357 =head1 COPYRIGHT AND LICENSE
359 Copyright 2006 by Infinity Interactive, Inc.
361 L<http://www.iinteractive.com>
363 This library is free software; you can redistribute it and/or modify
364 it under the same terms as Perl itself.