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.2205';
3              
4 390     390   3161 use strict;
  390         1006  
  390         12141  
5 390     390   2113 use warnings;
  390         932  
  390         9603  
6 390     390   2090 use metaclass;
  390         992  
  390         2268  
7              
8 390     390   4482 use B;
  390         1140  
  390         17074  
9 390     390   3956 use Moose::Util::TypeConstraints ();
  390         1277  
  390         8156  
10 390     390   2451 use Moose::Util ();
  390         1093  
  390         9674  
11              
12 390     390   2301 use parent 'Moose::Meta::TypeConstraint';
  390         1018  
  390         2779  
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 1293     1293 1 5638 my ( $class, %args ) = @_;
31              
32 1293         4267 $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Object');
33              
34 1293         4009 my $role_name = $args{role};
35 1293     0   7899 $args{constraint} = sub { Moose::Util::does_role( $_[0], $role_name ) };
  0         0  
36              
37 1293         3840 $args{inlined} = $inliner;
38              
39 1293         8855 my $self = $class->SUPER::new( \%args );
40              
41 1293         6135 $self->compile_type_constraint();
42              
43 1293         7026 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 15 my ( $self, $type_or_name ) = @_;
65              
66 5         14 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
67              
68 5 100       20 return unless defined $other;
69 4 50       15 return unless $other->isa(__PACKAGE__);
70              
71 4         131 return $self->role eq $other->role;
72             }
73              
74             sub is_a_type_of {
75 1     1 1 4 my ($self, $type_or_name) = @_;
76              
77 1         3 my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
78              
79 1 50       4 ($self->equals($type) || $self->is_subtype_of($type_or_name));
80             }
81              
82             sub is_subtype_of {
83 7     7 1 760 my ($self, $type_or_name_or_role ) = @_;
84              
85 7 100       22 if ( not ref $type_or_name_or_role ) {
86             # it might be a role
87 6         216 my $class = Class::MOP::class_of($self->role);
88 6 100 100     31 return 1 if defined($class) && $class->does_role( $type_or_name_or_role );
89             }
90              
91 5         18 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       22 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     61 return defined($class) && $class->does_role( $type->role );
100             } else {
101             # the only other thing we are a subtype of is Object
102 1         10 $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.2205
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