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