lib/Moose/Meta/TypeConstraint/Role.pm

   1 package Moose::Meta::TypeConstraint::Role;
   2
   3 use strict;
   4 use warnings;
   5 use metaclass;
   6
   7 use Scalar::Util 'blessed';
   8 use Moose::Util::TypeConstraints ();
   9
  10 our $AUTHORITY = 'cpan:STEVAN';
  11
  12 use base 'Moose::Meta::TypeConstraint';
  13
  14 __PACKAGE__->meta->add_attribute('role' => (
  15     reader => 'role',
  16 ));
  17
  18 sub new {
  19     my ( $class, %args ) = @_;
  20
  21     $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Object');
  22     my $self      = $class->_new(\%args);
  23
  24     $self->_create_hand_optimized_type_constraint;
  25     $self->compile_type_constraint();
  26
  27     return $self;
  28 }
  29
  30 sub _create_hand_optimized_type_constraint {
  31     my $self = shift;
  32     my $role = $self->role;
  33     $self->hand_optimized_type_constraint(
  34         sub { Moose::Util::does_role($_[0], $role) }
  35     );
  36 }
  37
  38 sub parents {
  39     my $self = shift;
  40     return (
  41         $self->parent,
  42         map {
  43             # FIXME find_type_constraint might find a TC named after the role but that isn't really it
  44             # I did this anyway since it's a convention that preceded TypeConstraint::Role, and it should DWIM
  45             # if anybody thinks this problematic please discuss on IRC.
  46             # a possible fix is to add by attr indexing to the type registry to find types of a certain property
  47             # regardless of their name
  48             Moose::Util::TypeConstraints::find_type_constraint($_)
  49                 ||
  50             __PACKAGE__->new( role => $_, name => "__ANON__" )
  51         } @{ Class::MOP::class_of($self->role)->get_roles },
  52     );
  53 }
  54
  55 sub equals {
  56     my ( $self, $type_or_name ) = @_;
  57
  58     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
  59
  60     return unless defined $other;
  61     return unless $other->isa(__PACKAGE__);
  62
  63     return $self->role eq $other->role;
  64 }
  65
  66 sub is_a_type_of {
  67     my ($self, $type_or_name) = @_;
  68
  69     my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
  70
  71     ($self->equals($type) || $self->is_subtype_of($type_or_name));
  72 }
  73
  74 sub is_subtype_of {
  75     my ($self, $type_or_name_or_role ) = @_;
  76
  77     if ( not ref $type_or_name_or_role ) {
  78         # it might be a role
  79         return 1 if Class::MOP::class_of($self->role)->does_role( $type_or_name_or_role );
  80     }
  81
  82     my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name_or_role);
  83
  84     return unless defined $type;
  85
  86     if ( $type->isa(__PACKAGE__) ) {
  87         # if $type_or_name_or_role isn't a role, it might be the TC name of another ::Role type
  88         # or it could also just be a type object in this branch
  89         return Class::MOP::class_of($self->role)->does_role( $type->role );
  90     } else {
  91         # the only other thing we are a subtype of is Object
  92         $self->SUPER::is_subtype_of($type);
  93     }
  94 }
  95
  96 sub create_child_type {
  97     my ($self, @args) = @_;
  98     return Moose::Meta::TypeConstraint->new(@args, parent => $self);
  99 }
 100
 101 1;
 102
 103 # ABSTRACT: Role/TypeConstraint parallel hierarchy
 104
 105 __END__
 106
 107 =pod
 108
 109 =head1 DESCRIPTION
 110
 111 This class represents type constraints for a role.
 112
 113 =head1 INHERITANCE
 114
 115 C<Moose::Meta::TypeConstraint::Role> is a subclass of
 116 L<Moose::Meta::TypeConstraint>.
 117
 118 =head1 METHODS
 119
 120 =over 4
 121
 122 =item B<< Moose::Meta::TypeConstraint::Role->new(%options) >>
 123
 124 This creates a new role type constraint based on the given
 125 C<%options>.
 126
 127 It takes the same options as its parent, with two exceptions. First,
 128 it requires an additional option, C<role>, which is name of the
 129 constraint's role.  Second, it automatically sets the parent to the
 130 C<Object> type.
 131
 132 The constructor also overrides the hand optimized type constraint with
 133 one it creates internally.
 134
 135 =item B<< $constraint->role >>
 136
 137 Returns the role name associated with the constraint.
 138
 139 =item B<< $constraint->parents >>
 140
 141 Returns all the type's parent types, corresponding to the roles that
 142 its role does.
 143
 144 =item B<< $constraint->is_subtype_of($type_name_or_object) >>
 145
 146 If the given type is also a role type, then this checks that the
 147 type's role does the other type's role.
 148
 149 Otherwise it falls back to the implementation in
 150 L<Moose::Meta::TypeConstraint>.
 151
 152 =item B<< $constraint->create_child_type(%options) >>
 153
 154 This returns a new L<Moose::Meta::TypeConstraint> object with the type
 155 as its parent.
 156
 157 Note that it does I<not> return a C<Moose::Meta::TypeConstraint::Role>
 158 object!
 159
 160 =back
 161
 162 =head1 BUGS
 163
 164 See L<Moose/BUGS> for details on reporting bugs.
 165
 166 =cut