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 $self->parent->_inline_check($val)
  26          . ' && do {' . "\n"
  27              . 'my $val = ' . $val . ';' . "\n"
  28              . '&List::MoreUtils::all(' . "\n"
  29                  . 'sub { $val->can($_) },' . "\n"
  30                  . join(', ', map { B::perlstring($_) } @{ $self->methods })
  31              . ');' . "\n"
  32          . '}';
  33 };
  34
  35 sub new {
  36     my ( $class, %args ) = @_;
  37
  38     $args{parent}
  39         = Moose::Util::TypeConstraints::find_type_constraint('Object');
  40
  41     my @methods = @{ $args{methods} };
  42     $args{constraint} = sub {
  43         my $val = $_[0];
  44         return all { $val->can($_) } @methods;
  45     };
  46
  47     $args{inlined} = $inliner;
  48
  49     my $self = $class->SUPER::new(\%args);
  50
  51     $self->compile_type_constraint()
  52         unless $self->_has_compiled_type_constraint;
  53
  54     return $self;
  55 }
  56
  57 sub equals {
  58     my ( $self, $type_or_name ) = @_;
  59
  60     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
  61
  62     return unless $other->isa(__PACKAGE__);
  63
  64     my @self_methods  = sort @{ $self->methods };
  65     my @other_methods = sort @{ $other->methods };
  66
  67     return unless @self_methods == @other_methods;
  68
  69     while ( @self_methods ) {
  70         my $method = shift @self_methods;
  71         my $other_method = shift @other_methods;
  72
  73         return unless $method eq $other_method;
  74     }
  75
  76     return 1;
  77 }
  78
  79 sub create_child_type {
  80     my ($self, @args) = @_;
  81     return Moose::Meta::TypeConstraint->new(@args, parent => $self);
  82 }
  83
  84 sub get_message {
  85     my $self = shift;
  86     my ($value) = @_;
  87
  88     if ($self->has_message) {
  89         return $self->SUPER::get_message(@_);
  90     }
  91
  92     return $self->SUPER::get_message($value) unless blessed($value);
  93
  94     my @methods = grep { !$value->can($_) } @{ $self->methods };
  95     my $class = blessed $value;
  96     $class ||= $value;
  97
  98     return $class
  99          . " is missing methods "
 100          . english_list(map { "'$_'" } @methods);
 101 }
 102
 103 1;
 104
 105 # ABSTRACT: Type constraint for duck typing
 106
 107 __END__
 108
 109 =pod
 110
 111 =head1 DESCRIPTION
 112
 113 This class represents type constraints based on an enumerated list of
 114 required methods.
 115
 116 =head1 INHERITANCE
 117
 118 C<Moose::Meta::TypeConstraint::DuckType> is a subclass of
 119 L<Moose::Meta::TypeConstraint>.
 120
 121 =head1 METHODS
 122
 123 =over 4
 124
 125 =item B<< Moose::Meta::TypeConstraint::DuckType->new(%options) >>
 126
 127 This creates a new duck type constraint based on the given
 128 C<%options>.
 129
 130 It takes the same options as its parent, with several
 131 exceptions. First, it requires an additional option, C<methods>. This
 132 should be an array reference containing a list of required method
 133 names. Second, it automatically sets the parent to the C<Object> type.
 134
 135 Finally, it ignores any provided C<constraint> option. The constraint
 136 is generated automatically based on the provided C<methods>.
 137
 138 =item B<< $constraint->methods >>
 139
 140 Returns the array reference of required methods provided to the
 141 constructor.
 142
 143 =item B<< $constraint->create_child_type >>
 144
 145 This returns a new L<Moose::Meta::TypeConstraint> object with the type
 146 as its parent.
 147
 148 Note that it does I<not> return a C<Moose::Meta::TypeConstraint::DuckType>
 149 object!
 150
 151 =back
 152
 153 =head1 BUGS
 154
 155 See L<Moose/BUGS> for details on reporting bugs.
 156
 157 =cut
 158