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;
61 # the code below is almost certainly incorrect
62 # but this is foreign inheritence, so we might
63 # have to kludge it in the end.
64 my $instance = $params{'__INSTANCE__'} || $meta_instance->create_instance();
65 foreach my $attr ($class->compute_all_applicable_attributes()) {
66 $attr->initialize_instance_slot($meta_instance, $instance, \%params)
72 my ($self, $method_name) = @_;
73 (defined $method_name && $method_name)
74 || confess "You must define a method name";
76 my $sub_name = ($self->name . '::' . $method_name);
79 return 0 if !defined(&{$sub_name});
80 my $method = \&{$sub_name};
82 return 1 if blessed($method) && $method->isa('Moose::Meta::Role::Method');
83 return $self->SUPER::has_method($method_name);
87 my ($self, $name, %params) = @_;
90 if ( my $delegation = delete $params{handles} ) {
91 my @method_names_or_hashes = $self->compute_delegation( $name, $delegation, \%params );
92 @delegations = $self->get_delegatable_methods( @method_names_or_hashes );
95 my $ret = $self->SUPER::add_attribute( $name, %params );
98 my $attr = $self->get_attribute( $name );
99 $self->generate_delgate_method( $attr, $_ ) for $self->filter_delegations( $attr, @delegations );
105 sub filter_delegations {
106 my ( $self, $attr, @delegations ) = @_;
108 my $new_name = $_->{new_name} || $_->{name};
109 no warnings "uninitialized";
111 !$self->name->can( $new_name ) and
112 $attr->accessor ne $new_name and
113 $attr->reader ne $new_name and
114 $attr->writer ne $new_name
119 sub generate_delgate_method {
120 my ( $self, $attr, $method ) = @_;
122 # FIXME like generated accessors these methods must be regenerated
123 # FIXME the reader may not work for subclasses with weird instances
125 my $make = $method->{generator} || sub {
126 my ( $self, $attr, $method ) = @_;
128 my $method_name = $method->{name};
129 my $reader = $attr->generate_reader_method();
132 if ( Scalar::Util::blessed( my $delegate = shift->$reader ) ) {
133 return $delegate->$method_name( @_ );
139 my $new_name = $method->{new_name} || $method->{name};
140 $self->add_method( $new_name, $make->( $self, $attr, $method ) );
143 sub compute_delegation {
144 my ( $self, $attr_name, $delegation, $params ) = @_;
147 # either it's a concrete list of method names
148 return $delegation unless ref $delegation; # single method name
149 return @$delegation if reftype($delegation) eq "ARRAY";
151 # or it's a generative api
152 my $delegator_meta = $self->_guess_attr_class_or_role( $attr_name, $params );
153 $self->generate_delegation_list( $delegation, $delegator_meta );
156 sub get_delegatable_methods {
157 my ( $self, @names_or_hashes ) = @_;
158 map { ref($_) ? $_ : { name => $_ } } @names_or_hashes;
161 sub generate_delegation_list {
162 my ( $self, $delegation, $delegator_meta ) = @_;
164 if ( reftype($delegation) eq "CODE" ) {
165 return $delegation->( $self, $delegator_meta );
166 } elsif ( blessed($delegation) eq "Regexp" ) {
167 confess "For regular expression support the delegator class/role must use a Class::MOP::Class metaclass"
168 unless $delegator_meta->isa( "Class::MOP::Class" );
169 return grep { $_->{name} =~ /$delegation/ } $delegator_meta->compute_all_applicable_methods();
171 confess "The 'handles' specification '$delegation' is not supported";
175 sub _guess_attr_class_or_role {
176 my ( $self, $attr, $params ) = @_;
178 my ( $isa, $does ) = @{ $params }{qw/isa does/};
180 confess "Generative delegations must explicitly specify a class or a role for the attribute's type"
181 unless $isa || $does;
183 for (grep { blessed($_) } $isa, $does) {
184 confess "You must use classes/roles, not type constraints to use delegation ($_)"
185 unless $_->isa( "Moose::Meta::Class" );
188 confess "Cannot have an isa option and a does option if the isa does not do the does"
189 if $isa and $does and $isa->can("does") and !$isa->does( $does );
191 # if it's a class/role name make it into a meta object
193 $_ = $_->meta if defined and !ref and $_->can("meta");
196 $isa = Class::MOP::Class->initialize($isa) if $isa and !ref($isa);
198 return $isa || $does;
201 sub add_override_method_modifier {
202 my ($self, $name, $method, $_super_package) = @_;
203 # need this for roles ...
204 $_super_package ||= $self->name;
205 my $super = $self->find_next_method_by_name($name);
207 || confess "You cannot override '$name' because it has no super method";
208 $self->add_method($name => bless sub {
211 no warnings 'redefine';
212 local *{$_super_package . '::super'} = sub { $super->(@args) };
213 return $method->(@args);
214 } => 'Moose::Meta::Method::Overriden');
217 sub add_augment_method_modifier {
218 my ($self, $name, $method) = @_;
219 my $super = $self->find_next_method_by_name($name);
221 || confess "You cannot augment '$name' because it has no super method";
222 my $_super_package = $super->package_name;
223 # BUT!,... if this is an overriden method ....
224 if ($super->isa('Moose::Meta::Method::Overriden')) {
225 # we need to be sure that we actually
226 # find the next method, which is not
227 # an 'override' method, the reason is
228 # that an 'override' method will not
229 # be the one calling inner()
230 my $real_super = $self->_find_next_method_by_name_which_is_not_overridden($name);
231 $_super_package = $real_super->package_name;
233 $self->add_method($name => sub {
236 no warnings 'redefine';
237 local *{$_super_package . '::inner'} = sub { $method->(@args) };
238 return $super->(@args);
242 sub _find_next_method_by_name_which_is_not_overridden {
243 my ($self, $name) = @_;
244 my @methods = $self->find_all_methods_by_name($name);
245 foreach my $method (@methods) {
246 return $method->{code}
247 if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden');
252 package Moose::Meta::Method::Overriden;
257 our $VERSION = '0.01';
259 use base 'Class::MOP::Method';
269 Moose::Meta::Class - The Moose metaclass
273 This is a subclass of L<Class::MOP::Class> with Moose specific
276 For the most part, the only time you will ever encounter an
277 instance of this class is if you are doing some serious deep
278 introspection. To really understand this class, you need to refer
279 to the L<Class::MOP::Class> documentation.
289 We override this method to support the C<trigger> attribute option.
291 =item B<construct_instance>
293 This provides some Moose specific extensions to this method, you
294 almost never call this method directly unless you really know what
297 This method makes sure to handle the moose weak-ref, type-constraint
298 and type coercion features.
300 =item B<has_method ($name)>
302 This accomidates Moose::Meta::Role::Method instances, which are
303 aliased, instead of added, but still need to be counted as valid
306 =item B<add_override_method_modifier ($name, $method)>
308 This will create an C<override> method modifier for you, and install
311 =item B<add_augment_method_modifier ($name, $method)>
313 This will create an C<augment> method modifier for you, and install
318 This will return an array of C<Moose::Meta::Role> instances which are
319 attached to this class.
321 =item B<add_role ($role)>
323 This takes an instance of C<Moose::Meta::Role> in C<$role>, and adds it
324 to the list of associated roles.
326 =item B<does_role ($role_name)>
328 This will test if this class C<does> a given C<$role_name>. It will
329 not only check it's local roles, but ask them as well in order to
330 cascade down the role hierarchy.
332 =item B<add_attribute $attr_name, %params>
334 This method does the same thing as L<Class::MOP::Class/add_attribute>, but adds
335 suport for delegation.
339 =head1 INTERNAL METHODS
343 =item compute_delegation
345 =item generate_delegation_list
347 =item generate_delgate_method
349 =item get_delegatable_methods
351 =item filter_delegations
357 All complex software has bugs lurking in it, and this module is no
358 exception. If you find a bug please either email me, or add the bug
363 Stevan Little E<lt>stevan@iinteractive.comE<gt>
365 =head1 COPYRIGHT AND LICENSE
367 Copyright 2006 by Infinity Interactive, Inc.
369 L<http://www.iinteractive.com>
371 This library is free software; you can redistribute it and/or modify
372 it under the same terms as Perl itself.