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