1 package Moose::Meta::TypeConstraint::DuckType;
7 use Scalar::Util 'blessed';
8 use List::MoreUtils qw(all);
9 use Moose::Util 'english_list';
11 use Moose::Util::TypeConstraints ();
13 our $VERSION = '1.23';
14 $VERSION = eval $VERSION;
15 our $AUTHORITY = 'cpan:STEVAN';
17 use base 'Moose::Meta::TypeConstraint';
19 __PACKAGE__->meta->add_attribute('methods' => (
20 accessor => 'methods',
24 my ( $class, %args ) = @_;
26 $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Object');
28 my $self = $class->_new(\%args);
30 $self->compile_type_constraint()
31 unless $self->_has_compiled_type_constraint;
37 my ( $self, $type_or_name ) = @_;
39 my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
41 return unless $other->isa(__PACKAGE__);
43 my @self_methods = sort @{ $self->methods };
44 my @other_methods = sort @{ $other->methods };
46 return unless @self_methods == @other_methods;
48 while ( @self_methods ) {
49 my $method = shift @self_methods;
50 my $other_method = shift @other_methods;
52 return unless $method eq $other_method;
61 my @methods = @{ $self->methods };
65 return all { $obj->can($_) } @methods
69 sub _compile_hand_optimized_type_constraint {
72 my @methods = @{ $self->methods };
78 && blessed($obj) ne 'Regexp'
79 && all { $obj->can($_) } @methods;
83 sub create_child_type {
84 my ($self, @args) = @_;
85 return Moose::Meta::TypeConstraint->new(@args, parent => $self);
92 if ($self->has_message) {
93 return $self->SUPER::get_message(@_);
96 my @methods = grep { !$value->can($_) } @{ $self->methods };
97 my $class = blessed $value;
99 . " is missing methods "
100 . english_list(map { "'$_'" } @methods);
111 Moose::Meta::TypeConstraint::DuckType - Type constraint for duck typing
115 This class represents type constraints based on an enumerated list of
120 C<Moose::Meta::TypeConstraint::DuckType> is a subclass of
121 L<Moose::Meta::TypeConstraint>.
127 =item B<< Moose::Meta::TypeConstraint::DuckType->new(%options) >>
129 This creates a new duck type constraint based on the given
132 It takes the same options as its parent, with several
133 exceptions. First, it requires an additional option, C<methods>. This
134 should be an array reference containing a list of required method
135 names. Second, it automatically sets the parent to the C<Object> type.
137 Finally, it ignores any provided C<constraint> option. The constraint
138 is generated automatically based on the provided C<methods>.
140 =item B<< $constraint->methods >>
142 Returns the array reference of required methods provided to the
145 =item B<< $constraint->create_child_type >>
147 This returns a new L<Moose::Meta::TypeConstraint> object with the type
150 Note that it does I<not> return a C<Moose::Meta::TypeConstraint::DuckType>
157 See L<Moose/BUGS> for details on reporting bugs.
161 Chris Prather E<lt>chris@prather.orgE<gt>
163 Shawn M Moore E<lt>sartak@gmail.comE<gt>
165 =head1 COPYRIGHT AND LICENSE
167 Copyright 2006-2010 by Infinity Interactive, Inc.
169 L<http://www.iinteractive.com>
171 This library is free software; you can redistribute it and/or modify
172 it under the same terms as Perl itself.