lib/Moose/Meta/TypeConstraint/DuckType.pm

   1 package Moose::Meta::TypeConstraint::DuckType;
   2
   3 use strict;
   4 use warnings;
   5 use metaclass;
   6
   7 use B;
   8 use Scalar::Util 'blessed';
   9 use List::MoreUtils qw(all);
  10 use Moose::Util 'english_list';
  11
  12 use Moose::Util::TypeConstraints ();
  13
  14 use base 'Moose::Meta::TypeConstraint';
  15
  16 __PACKAGE__->meta->add_attribute('methods' => (
  17     accessor => 'methods',
  18     Class::MOP::_definition_context(),
  19 ));
  20
  21 my $inliner = sub {
  22     my $self = shift;
  23     my $val  = shift;
  24
  25     return 'Scalar::Util::blessed(' . $val . ') '
  26              . '&& Scalar::Util::blessed(' . $val . ') ne "Regexp" '
  27              . '&& &List::MoreUtils::all('
  28                  . 'sub { ' . $val . '->can($_) }, '
  29                  . join(', ', map { B::perlstring($_) } @{ $self->methods })
  30              . ')';
  31 };
  32
  33 sub new {
  34     my ( $class, %args ) = @_;
  35
  36     $args{parent}
  37         = Moose::Util::TypeConstraints::find_type_constraint('Object');
  38
  39     my @methods = @{ $args{methods} };
  40     $args{constraint} = sub {
  41         blessed( $_[0] ) ne 'Regexp'
  42             && all { $_[0]->can($_) } @methods;
  43     };
  44
  45     $args{inlined} = $inliner;
  46
  47     my $self = $class->SUPER::new(\%args);
  48
  49     $self->compile_type_constraint()
  50         unless $self->_has_compiled_type_constraint;
  51
  52     return $self;
  53 }
  54
  55 sub equals {
  56     my ( $self, $type_or_name ) = @_;
  57
  58     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
  59
  60     return unless $other->isa(__PACKAGE__);
  61
  62     my @self_methods  = sort @{ $self->methods };
  63     my @other_methods = sort @{ $other->methods };
  64
  65     return unless @self_methods == @other_methods;
  66
  67     while ( @self_methods ) {
  68         my $method = shift @self_methods;
  69         my $other_method = shift @other_methods;
  70
  71         return unless $method eq $other_method;
  72     }
  73
  74     return 1;
  75 }
  76
  77 sub constraint {
  78     my $self = shift;
  79
  80     my @methods = @{ $self->methods };
  81
  82     return sub {
  83         my $obj = shift;
  84         return all { $obj->can($_) } @methods
  85     };
  86 }
  87
  88 sub create_child_type {
  89     my ($self, @args) = @_;
  90     return Moose::Meta::TypeConstraint->new(@args, parent => $self);
  91 }
  92
  93 sub get_message {
  94     my $self = shift;
  95     my ($value) = @_;
  96
  97     if ($self->has_message) {
  98         return $self->SUPER::get_message(@_);
  99     }
 100
 101     return $self->SUPER::get_message($value) unless blessed($value);
 102
 103     my @methods = grep { !$value->can($_) } @{ $self->methods };
 104     my $class = blessed $value;
 105     $class ||= $value;
 106
 107     return $class
 108          . " is missing methods "
 109          . english_list(map { "'$_'" } @methods);
 110 }
 111
 112 1;
 113
 114 # ABSTRACT: Type constraint for duck typing
 115
 116 __END__
 117
 118 =pod
 119
 120 =head1 DESCRIPTION
 121
 122 This class represents type constraints based on an enumerated list of
 123 required methods.
 124
 125 =head1 INHERITANCE
 126
 127 C<Moose::Meta::TypeConstraint::DuckType> is a subclass of
 128 L<Moose::Meta::TypeConstraint>.
 129
 130 =head1 METHODS
 131
 132 =over 4
 133
 134 =item B<< 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 =item B<< $constraint->methods >>
 148
 149 Returns the array reference of required methods provided to the
 150 constructor.
 151
 152 =item B<< $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 =back
 161
 162 =head1 BUGS
 163
 164 See L<Moose/BUGS> for details on reporting bugs.
 165
 166 =cut
 167