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