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