File Coverage

blib/lib/Moose/Meta/TypeConstraint/DuckType.pm
Criterion Covered Total %
statement 50 66 75.7
branch 4 12 33.3
condition 1 3 33.3
subroutine 12 14 85.7
pod 4 4 100.0
total 71 99 71.7


line stmt bran cond sub pod time code
1             package Moose::Meta::TypeConstraint::DuckType;
2             our $VERSION = '2.2205';
3              
4 390     390   3032 use strict;
  390         1095  
  390         12300  
5 390     390   2263 use warnings;
  390         993  
  390         9873  
6 390     390   2191 use metaclass;
  390         992  
  390         2236  
7              
8 390     390   3088 use B;
  390         1131  
  390         18233  
9 390     390   2872 use Scalar::Util 'blessed';
  390         1235  
  390         28657  
10 390     390   3097 use List::Util 1.33 qw(all);
  390         10000  
  390         26959  
11 390     390   3116 use Moose::Util 'english_list';
  390         1071  
  390         3060  
12              
13 390     390   102026 use Moose::Util::TypeConstraints ();
  390         1039  
  390         9255  
14              
15 390     390   2284 use parent 'Moose::Meta::TypeConstraint';
  390         1021  
  390         2564  
16              
17             __PACKAGE__->meta->add_attribute('methods' => (
18             accessor => 'methods',
19             Class::MOP::_definition_context(),
20             ));
21              
22             my $inliner = sub {
23             my $self = shift;
24             my $val = shift;
25              
26             return $self->parent->_inline_check($val)
27             . ' && do {' . "\n"
28             . 'my $val = ' . $val . ';' . "\n"
29             . '&List::Util::all(' . "\n"
30             . 'sub { $val->can($_) },' . "\n"
31             . join(', ', map { B::perlstring($_) } @{ $self->methods })
32             . ');' . "\n"
33             . '}';
34             };
35              
36             sub new {
37 25     25 1 143 my ( $class, %args ) = @_;
38              
39             $args{parent}
40 25         107 = Moose::Util::TypeConstraints::find_type_constraint('Object');
41              
42 25         84 my @methods = @{ $args{methods} };
  25         119  
43             $args{constraint} = sub {
44 8     8   18 my $val = $_[0];
45 8         52 return all { $val->can($_) } @methods;
  10         90  
46 25         182 };
47              
48 25         80 $args{inlined} = $inliner;
49              
50 25         253 my $self = $class->SUPER::new(\%args);
51              
52 25 50       1007 $self->compile_type_constraint()
53             unless $self->_has_compiled_type_constraint;
54              
55 25         215 return $self;
56             }
57              
58             sub equals {
59 0     0 1 0 my ( $self, $type_or_name ) = @_;
60              
61 0         0 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
62              
63 0 0       0 return unless $other->isa(__PACKAGE__);
64              
65 0         0 my @self_methods = sort @{ $self->methods };
  0         0  
66 0         0 my @other_methods = sort @{ $other->methods };
  0         0  
67              
68 0 0       0 return unless @self_methods == @other_methods;
69              
70 0         0 while ( @self_methods ) {
71 0         0 my $method = shift @self_methods;
72 0         0 my $other_method = shift @other_methods;
73              
74 0 0       0 return unless $method eq $other_method;
75             }
76              
77 0         0 return 1;
78             }
79              
80             sub create_child_type {
81 0     0 1 0 my ($self, @args) = @_;
82 0         0 return Moose::Meta::TypeConstraint->new(@args, parent => $self);
83             }
84              
85             sub get_message {
86 31     31 1 72 my $self = shift;
87 31         60 my ($value) = @_;
88              
89 31 50       983 if ($self->has_message) {
90 0         0 return $self->SUPER::get_message(@_);
91             }
92              
93 31 100       182 return $self->SUPER::get_message($value) unless blessed($value);
94              
95 7         26 my @methods = grep { !$value->can($_) } @{ $self->methods };
  13         80  
  7         219  
96 7         28 my $class = blessed $value;
97 7   33     33 $class ||= $value;
98              
99             return $class
100             . " is missing methods "
101 7         25 . english_list(map { "'$_'" } @methods);
  12         58  
102             }
103              
104             1;
105              
106             # ABSTRACT: Type constraint for duck typing
107              
108             __END__
109              
110             =pod
111              
112             =encoding UTF-8
113              
114             =head1 NAME
115              
116             Moose::Meta::TypeConstraint::DuckType - Type constraint for duck typing
117              
118             =head1 VERSION
119              
120             version 2.2205
121              
122             =head1 DESCRIPTION
123              
124             This class represents type constraints based on an enumerated list of
125             required methods.
126              
127             =head1 INHERITANCE
128              
129             C<Moose::Meta::TypeConstraint::DuckType> is a subclass of
130             L<Moose::Meta::TypeConstraint>.
131              
132             =head1 METHODS
133              
134             =head2 Moose::Meta::TypeConstraint::DuckType->new(%options)
135              
136             This creates a new duck type constraint based on the given
137             C<%options>.
138              
139             It takes the same options as its parent, with several
140             exceptions. First, it requires an additional option, C<methods>. This
141             should be an array reference containing a list of required method
142             names. Second, it automatically sets the parent to the C<Object> type.
143              
144             Finally, it ignores any provided C<constraint> option. The constraint
145             is generated automatically based on the provided C<methods>.
146              
147             =head2 $constraint->methods
148              
149             Returns the array reference of required methods provided to the
150             constructor.
151              
152             =head2 $constraint->create_child_type
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::DuckType>
158             object!
159              
160             =head1 BUGS
161              
162             See L<Moose/BUGS> for details on reporting bugs.
163              
164             =head1 AUTHORS
165              
166             =over 4
167              
168             =item *
169              
170             Stevan Little <stevan@cpan.org>
171              
172             =item *
173              
174             Dave Rolsky <autarch@urth.org>
175              
176             =item *
177              
178             Jesse Luehrs <doy@cpan.org>
179              
180             =item *
181              
182             Shawn M Moore <sartak@cpan.org>
183              
184             =item *
185              
186             יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
187              
188             =item *
189              
190             Karen Etheridge <ether@cpan.org>
191              
192             =item *
193              
194             Florian Ragwitz <rafl@debian.org>
195              
196             =item *
197              
198             Hans Dieter Pearcey <hdp@cpan.org>
199              
200             =item *
201              
202             Chris Prather <chris@prather.org>
203              
204             =item *
205              
206             Matt S Trout <mstrout@cpan.org>
207              
208             =back
209              
210             =head1 COPYRIGHT AND LICENSE
211              
212             This software is copyright (c) 2006 by Infinity Interactive, Inc.
213              
214             This is free software; you can redistribute it and/or modify it under
215             the same terms as the Perl 5 programming language system itself.
216              
217             =cut