File Coverage

blib/lib/Moose/Meta/TypeConstraint/Role.pm
Criterion Covered Total %
statement 47 54 87.0
branch 12 16 75.0
condition 5 6 83.3
subroutine 11 14 78.5
pod 6 6 100.0
total 81 96 84.3


line stmt bran cond sub pod time code
1             package Moose::Meta::TypeConstraint::Role;
2             our $VERSION = '2.2203';
3              
4 401     401   2867 use strict;
  401         835  
  401         11156  
5 401     401   1898 use warnings;
  401         786  
  401         9153  
6 401     401   1909 use metaclass;
  401         826  
  401         2083  
7              
8 401     401   4114 use B;
  401         970  
  401         15791  
9 401     401   3560 use Moose::Util::TypeConstraints ();
  401         983  
  401         7393  
10 401     401   2127 use Moose::Util ();
  401         874  
  401         9179  
11              
12 401     401   2192 use parent 'Moose::Meta::TypeConstraint';
  401         1188  
  401         2333  
13              
14             __PACKAGE__->meta->add_attribute('role' => (
15             reader => 'role',
16             Class::MOP::_definition_context(),
17             ));
18              
19             my $inliner = sub {
20             my $self = shift;
21             my $val = shift;
22              
23             return 'Moose::Util::does_role('
24             . $val . ', '
25             . B::perlstring($self->role)
26             . ')';
27             };
28              
29             sub new {
30 1299     1299 1 4937 my ( $class, %args ) = @_;
31              
32 1299         3830 $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Object');
33              
34 1299         2970 my $role_name = $args{role};
35 1299     0   6566 $args{constraint} = sub { Moose::Util::does_role( $_[0], $role_name ) };
  0         0  
36              
37 1299         3236 $args{inlined} = $inliner;
38              
39 1299         7655 my $self = $class->SUPER::new( \%args );
40              
41 1299         5193 $self->compile_type_constraint();
42              
43 1299         5989 return $self;
44             }
45              
46             sub parents {
47 0     0 1 0 my $self = shift;
48             return (
49             $self->parent,
50             map {
51             # FIXME find_type_constraint might find a TC named after the role but that isn't really it
52             # I did this anyway since it's a convention that preceded TypeConstraint::Role, and it should DWIM
53             # if anybody thinks this problematic please discuss on IRC.
54             # a possible fix is to add by attr indexing to the type registry to find types of a certain property
55             # regardless of their name
56 0 0       0 Moose::Util::TypeConstraints::find_type_constraint($_)
57             ||
58             __PACKAGE__->new( role => $_, name => "__ANON__" )
59 0         0 } @{ Class::MOP::class_of($self->role)->get_roles },
  0         0  
60             );
61             }
62              
63             sub equals {
64 5     5 1 16 my ( $self, $type_or_name ) = @_;
65              
66 5         14 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
67              
68 5 100       23 return unless defined $other;
69 4 50       14 return unless $other->isa(__PACKAGE__);
70              
71 4         129 return $self->role eq $other->role;
72             }
73              
74             sub is_a_type_of {
75 1     1 1 12 my ($self, $type_or_name) = @_;
76              
77 1         5 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
78              
79 1 50       7 ($self->equals($type) || $self->is_subtype_of($type_or_name));
80             }
81              
82             sub is_subtype_of {
83 7     7 1 864 my ($self, $type_or_name_or_role ) = @_;
84              
85 7 100       20 if ( not ref $type_or_name_or_role ) {
86             # it might be a role
87 6         215 my $class = Class::MOP::class_of($self->role);
88 6 100 100     29 return 1 if defined($class) && $class->does_role( $type_or_name_or_role );
89             }
90              
91 5         19 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name_or_role);
92              
93 5 100       29 return unless defined $type;
94              
95 3 100       17 if ( $type->isa(__PACKAGE__) ) {
96             # if $type_or_name_or_role isn't a role, it might be the TC name of another ::Role type
97             # or it could also just be a type object in this branch
98 2         61 my $class = Class::MOP::class_of($self->role);
99 2   66     56 return defined($class) && $class->does_role( $type->role );
100             } else {
101             # the only other thing we are a subtype of is Object
102 1         8 $self->SUPER::is_subtype_of($type);
103             }
104             }
105              
106             sub create_child_type {
107 0     0 1   my ($self, @args) = @_;
108 0           return Moose::Meta::TypeConstraint->new(@args, parent => $self);
109             }
110              
111             1;
112              
113             # ABSTRACT: Role/TypeConstraint parallel hierarchy
114              
115             __END__
116              
117             =pod
118              
119             =encoding UTF-8
120              
121             =head1 NAME
122              
123             Moose::Meta::TypeConstraint::Role - Role/TypeConstraint parallel hierarchy
124              
125             =head1 VERSION
126              
127             version 2.2203
128              
129             =head1 DESCRIPTION
130              
131             This class represents type constraints for a role.
132              
133             =head1 INHERITANCE
134              
135             C<Moose::Meta::TypeConstraint::Role> is a subclass of
136             L<Moose::Meta::TypeConstraint>.
137              
138             =head1 METHODS
139              
140             =head2 Moose::Meta::TypeConstraint::Role->new(%options)
141              
142             This creates a new role type constraint based on the given
143             C<%options>.
144              
145             It takes the same options as its parent, with two exceptions. First,
146             it requires an additional option, C<role>, which is name of the
147             constraint's role. Second, it automatically sets the parent to the
148             C<Object> type.
149              
150             The constructor also overrides the hand optimized type constraint with
151             one it creates internally.
152              
153             =head2 $constraint->role
154              
155             Returns the role name associated with the constraint.
156              
157             =head2 $constraint->parents
158              
159             Returns all the type's parent types, corresponding to the roles that
160             its role does.
161              
162             =head2 $constraint->is_subtype_of($type_name_or_object)
163              
164             If the given type is also a role type, then this checks that the
165             type's role does the other type's role.
166              
167             Otherwise it falls back to the implementation in
168             L<Moose::Meta::TypeConstraint>.
169              
170             =head2 $constraint->create_child_type(%options)
171              
172             This returns a new L<Moose::Meta::TypeConstraint> object with the type
173             as its parent.
174              
175             Note that it does I<not> return a C<Moose::Meta::TypeConstraint::Role>
176             object!
177              
178             =head1 BUGS
179              
180             See L<Moose/BUGS> for details on reporting bugs.
181              
182             =head1 AUTHORS
183              
184             =over 4
185              
186             =item *
187              
188             Stevan Little <stevan@cpan.org>
189              
190             =item *
191              
192             Dave Rolsky <autarch@urth.org>
193              
194             =item *
195              
196             Jesse Luehrs <doy@cpan.org>
197              
198             =item *
199              
200             Shawn M Moore <sartak@cpan.org>
201              
202             =item *
203              
204             יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
205              
206             =item *
207              
208             Karen Etheridge <ether@cpan.org>
209              
210             =item *
211              
212             Florian Ragwitz <rafl@debian.org>
213              
214             =item *
215              
216             Hans Dieter Pearcey <hdp@cpan.org>
217              
218             =item *
219              
220             Chris Prather <chris@prather.org>
221              
222             =item *
223              
224             Matt S Trout <mstrout@cpan.org>
225              
226             =back
227              
228             =head1 COPYRIGHT AND LICENSE
229              
230             This software is copyright (c) 2006 by Infinity Interactive, Inc.
231              
232             This is free software; you can redistribute it and/or modify it under
233             the same terms as the Perl 5 programming language system itself.
234              
235             =cut