1 package Moose::Meta::TypeConstraint::Role;
7 use Scalar::Util 'blessed';
8 use Moose::Util::TypeConstraints ();
10 our $VERSION = '1.25';
11 $VERSION = eval $VERSION;
12 our $AUTHORITY = 'cpan:STEVAN';
14 use base 'Moose::Meta::TypeConstraint';
16 __PACKAGE__->meta->add_attribute('role' => (
21 my ( $class, %args ) = @_;
23 $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Object');
24 my $self = $class->_new(\%args);
26 $self->_create_hand_optimized_type_constraint;
27 $self->compile_type_constraint();
32 sub _create_hand_optimized_type_constraint {
34 my $role = $self->role;
35 $self->hand_optimized_type_constraint(
36 sub { Moose::Util::does_role($_[0], $role) }
45 # FIXME find_type_constraint might find a TC named after the role but that isn't really it
46 # I did this anyway since it's a convention that preceded TypeConstraint::Role, and it should DWIM
47 # if anybody thinks this problematic please discuss on IRC.
48 # a possible fix is to add by attr indexing to the type registry to find types of a certain property
49 # regardless of their name
50 Moose::Util::TypeConstraints::find_type_constraint($_)
52 __PACKAGE__->new( role => $_, name => "__ANON__" )
53 } @{ Class::MOP::class_of($self->role)->get_roles },
58 my ( $self, $type_or_name ) = @_;
60 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
62 return unless defined $other;
63 return unless $other->isa(__PACKAGE__);
65 return $self->role eq $other->role;
69 my ($self, $type_or_name) = @_;
71 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
73 ($self->equals($type) || $self->is_subtype_of($type_or_name));
77 my ($self, $type_or_name_or_role ) = @_;
79 if ( not ref $type_or_name_or_role ) {
81 return 1 if Class::MOP::class_of($self->role)->does_role( $type_or_name_or_role );
84 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name_or_role);
86 return unless defined $type;
88 if ( $type->isa(__PACKAGE__) ) {
89 # if $type_or_name_or_role isn't a role, it might be the TC name of another ::Role type
90 # or it could also just be a type object in this branch
91 return Class::MOP::class_of($self->role)->does_role( $type->role );
93 # the only other thing we are a subtype of is Object
94 $self->SUPER::is_subtype_of($type);
98 sub create_child_type {
99 my ($self, @args) = @_;
100 return Moose::Meta::TypeConstraint->new(@args, parent => $self);
111 Moose::Meta::TypeConstraint::Role - Role/TypeConstraint parallel hierarchy
115 This class represents type constraints for a role.
119 C<Moose::Meta::TypeConstraint::Role> is a subclass of
120 L<Moose::Meta::TypeConstraint>.
126 =item B<< Moose::Meta::TypeConstraint::Role->new(%options) >>
128 This creates a new role type constraint based on the given
131 It takes the same options as its parent, with two exceptions. First,
132 it requires an additional option, C<role>, which is name of the
133 constraint's role. Second, it automatically sets the parent to the
136 The constructor also overrides the hand optimized type constraint with
137 one it creates internally.
139 =item B<< $constraint->role >>
141 Returns the role name associated with the constraint.
143 =item B<< $constraint->parents >>
145 Returns all the type's parent types, corresponding to the roles that
148 =item B<< $constraint->is_subtype_of($type_name_or_object) >>
150 If the given type is also a role type, then this checks that the
151 type's role does the other type's role.
153 Otherwise it falls back to the implementation in
154 L<Moose::Meta::TypeConstraint>.
156 =item B<< $constraint->create_child_type(%options) >>
158 This returns a new L<Moose::Meta::TypeConstraint> object with the type
161 Note that it does I<not> return a C<Moose::Meta::TypeConstraint::Role>
168 See L<Moose/BUGS> for details on reporting bugs.
172 Yuval Kogman E<lt>nothingmuch@cpan.orgE<gt>
174 =head1 COPYRIGHT AND LICENSE
176 Copyright 2006-2010 by Infinity Interactive, Inc.
178 L<http://www.iinteractive.com>
180 This library is free software; you can redistribute it and/or modify
181 it under the same terms as Perl itself.