File Coverage

blib/lib/Parse/Method/Signatures/TypeConstraint.pm
Criterion Covered Total %
statement 54 62 87.1
branch 11 28 39.2
condition 8 24 33.3
subroutine 18 18 100.0
pod 1 1 100.0
total 92 133 69.1


line stmt bran cond sub pod time code
1             package Parse::Method::Signatures::TypeConstraint;
2              
3 3     3   2248 use Carp qw/croak carp/;
  3         6  
  3         201  
4 3     3   12 use Moose;
  3         5  
  3         20  
5 3     3   9124 use MooseX::Types::Util qw/has_available_type_export/;
  3         4  
  3         152  
6 3     3   13 use MooseX::Types::Moose qw/Str HashRef CodeRef ClassName/;
  3         6  
  3         23  
7 3     3   10947 use Parse::Method::Signatures::Types qw/TypeConstraint/;
  3         5  
  3         52  
8              
9 3     3   3993 use namespace::clean -except => 'meta';
  3         4  
  3         40  
10              
11             has ppi => (
12             is => 'ro',
13             isa => 'PPI::Element',
14             required => 1,
15             handles => {
16             'to_string' => 'content'
17             }
18             );
19              
20             has tc => (
21             is => 'ro',
22             isa => TypeConstraint,
23             lazy => 1,
24             builder => '_build_tc',
25             );
26              
27             has from_namespace => (
28             is => 'ro',
29             isa => ClassName,
30             predicate => 'has_from_namespace'
31             );
32              
33             has tc_callback => (
34             is => 'ro',
35             isa => CodeRef,
36             default => sub { \&find_registered_constraint },
37             );
38              
39             sub find_registered_constraint {
40 9     9 1 23 my ($self, $name) = @_;
41              
42 9         11 my $type;
43 9 50       326 if ($self->has_from_namespace) {
44 0         0 my $pkg = $self->from_namespace;
45              
46 0 0       0 if ($type = has_available_type_export($pkg, $name)) {
    0          
47 0 0 0     0 croak "The type '$name' was found in $pkg " .
48             "but it hasn't yet been defined. Perhaps you need to move the " .
49             "definition into a type library or a BEGIN block.\n"
50             if $type && $type->isa('MooseX::Types::UndefinedType');
51             }
52             elsif ($name !~ /::/) {
53 0   0     0 my $meta = Class::MOP::class_of($pkg) || Class::MOP::Class->initialize($pkg);
54 0         0 my $func = $meta->get_package_symbol('&' . $name);
55 0 0       0 my $proto = prototype $func if $func;
56              
57 0 0 0     0 $name = $func->()
      0        
58             if $func && defined $proto && !length $proto;
59             }
60             }
61              
62 9         39 my $registry = Moose::Util::TypeConstraints->get_type_constraint_registry;
63 9   66     54 return $type || $registry->find_type_constraint($name) || $name;
64             }
65              
66              
67             sub _build_tc {
68 5     5   5 my ($self) = @_;
69 5         144 my $tc = $self->_walk_data($self->ppi);
70              
71             # This makes the error appear from the right place
72             local $Carp::Internal{'Class::MOP::Method::Generated'} = 1
73 5 50       3449 unless exists $Carp::Internal{'Class::MOP::Method::Generated'};
74              
75 5 50       22 croak "'@{[$self->ppi]}' could not be parsed to a type constraint - maybe you need to "
  0         0  
76             . "pre-declare the type with class_type"
77             unless blessed $tc;
78 5         143 return $tc;
79             }
80              
81             sub _walk_data {
82 13     13   18 my ($self, $data) = @_;
83              
84 13 50 66     30 my $res = $self->_union_node($data)
85             || $self->_params_node($data)
86             || $self->_str_node($data)
87             || $self->_leaf($data)
88             or confess 'failed to visit tc';
89 13         18 return $res->();
90             }
91              
92             sub _leaf {
93 7     7   9 my ($self, $data) = @_;
94              
95 7     7   40 sub { $self->_invoke_callback($data->content) };
  7         21  
96             }
97              
98             sub _union_node {
99 13     13   10 my ($self, $data) = @_;
100 13 100       106 return unless $data->isa('PPI::Statement::Expression::TCUnion');
101              
102 2         12 my @types = map { $self->_walk_data($_) } $data->children;
  4         8303  
103             sub {
104 2 50   2   17 scalar @types == 1 ? @types
105             : Moose::Meta::TypeConstraint::Union->new(type_constraints => \@types)
106 2         154 };
107             }
108              
109             sub _params_node {
110 11     11   13 my ($self, $data) = @_;
111 11 100       72 return unless $data->isa('PPI::Statement::Expression::TCParams');
112              
113 3         6 my @params = map { $self->_walk_data($_) } @{$data->params};
  4         80  
  3         97  
114 3         693 my $type = $self->_invoke_callback($data->type);
115 3     3   18 sub { $type->parameterize(@params) }
116 3         347 }
117              
118              
119             sub _str_node {
120 8     8   10 my ($self, $data) = @_;
121 8 50 66     107 return unless $data->isa('PPI::Token::StringifiedWord')
      66        
122             || $data->isa('PPI::Token::Number')
123             || $data->isa('PPI::Token::Quote');
124              
125             sub {
126 1 50   1   10 $data->isa('PPI::Token::Number')
127             ? $data->content
128             : $data->string
129 1         9 };
130             }
131              
132             sub _invoke_callback {
133 10     10   35 my $self = shift;
134 10         309 $self->tc_callback->($self, @_);
135             }
136              
137             __PACKAGE__->meta->make_immutable;
138              
139             1;
140              
141             __END__
142              
143             =head1 NAME
144              
145             Parse::Method::Signatures::TypeConstraint - turn parsed TC data into Moose TC object
146              
147             =head1 DESCRIPTION
148              
149             Class used to turn PPI elements into L<Moose::Meta::TypeConstraint> objects.
150              
151             =head1 ATTRIBUTES
152              
153             =head2 tc
154              
155             =over
156              
157             B<Lazy Build.>
158              
159             =back
160              
161             The L<Moose::Meta::TypeConstraint> object for this type constraint, built when
162             requested. L</tc_callback> will be called for each individual component type in
163             turn.
164              
165             =head2 tc_callback
166              
167             =over
168              
169             B<Type:> CodeRef
170              
171             B<Default:> L</find_registered_constraint>
172              
173             =back
174              
175             Callback used to turn type names into type objects. See
176             L<Parse::Method::Signatures/type_constraint_callback> for more details and an
177             example.
178              
179             =head2 from_namespace
180              
181             =over
182              
183             B<Type:> ClassName
184              
185             =back
186              
187             If provided, then the default C<tc_callback> will search for L<MooseX::Types>
188             in this package.
189              
190             =head1 METHODS
191              
192             =head2 find_registered_constraint
193              
194             Will search for an imported L<MooseX::Types> in L</from_namespace> (if
195             provided). Failing that it will ask the L<Moose::Meta::TypeConstraint::Registry>
196             for a type with the given name.
197              
198             If all else fails, it will simple return the type as a string, so that Moose's
199             auto-vivification of classnames to type will work.
200              
201             =head2 to_string
202              
203             String representation of the type constraint, approximately as parsed.
204              
205             =head1 SEE ALSO
206              
207             L<Parse::Method::Signatures>, L<MooseX::Types>, L<MooseX::Types::Util>.
208              
209             =head1 AUTHORS
210              
211             Florian Ragwitz <rafl@debian.org>.
212              
213             Ash Berlin <ash@cpan.org>.
214              
215             =head1 LICENSE
216              
217             Licensed under the same terms as Perl itself.
218