From: Shawn M Moore Date: Thu, 25 Jun 2009 06:26:49 +0000 (-0400) Subject: Reify duck type from a regular subtype into an actual class X-Git-Tag: 0.84~30 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0a6bff54f187f41f2df406cc732d53b4d9100d59;p=gitmo%2FMoose.git Reify duck type from a regular subtype into an actual class --- diff --git a/Changes b/Changes index ee23202..54eb148 100644 --- a/Changes +++ b/Changes @@ -8,6 +8,11 @@ for, noteworthy changes. - Methods generated by delegation were not being added to associated_methods. (hdp) + * Moose::Util::TypeConstraints + * Moose::Meta::TypeConstraint::DuckType + - Reify duck type from a regular subtype into an actual class + (Sartak) + 0.83 Tue, Jun 23, 2009 * Moose::Meta::Class - Fix _construct_instance not setting the special __MOP__ object diff --git a/lib/Moose/Meta/TypeConstraint/DuckType.pm b/lib/Moose/Meta/TypeConstraint/DuckType.pm new file mode 100644 index 0000000..e2b1b05 --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint/DuckType.pm @@ -0,0 +1,176 @@ +package Moose::Meta::TypeConstraint::DuckType; + +use strict; +use warnings; +use metaclass; + +use List::MoreUtils qw(all); +use Moose::Util 'english_list'; + +use Moose::Util::TypeConstraints (); + +our $VERSION = '0.83'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Moose::Meta::TypeConstraint'; + +__PACKAGE__->meta->add_attribute('methods' => ( + accessor => 'methods', +)); + +sub new { + my ( $class, %args ) = @_; + + $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Object'); + + my $self = $class->_new(\%args); + + $self->compile_type_constraint() + unless $self->_has_compiled_type_constraint; + + return $self; +} + +sub equals { + my ( $self, $type_or_name ) = @_; + + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); + + return unless $other->isa(__PACKAGE__); + + my @self_methods = sort @{ $self->methods }; + my @other_methods = sort @{ $other->methods }; + + return unless @self_methods == @other_methods; + + while ( @self_methods ) { + my $method = shift @self_methods; + my $other_method = shift @other_methods; + + return unless $method eq $other_method; + } + + return 1; +} + +sub constraint { + my $self = shift; + + my @methods = @{ $self->methods }; + + return sub { + my $obj = shift; + return all { $obj->can($_) } @methods + }; +} + +sub _compile_hand_optimized_type_constraint { + my $self = shift; + + my @methods = @{ $self->methods }; + + sub { + my $obj = shift; + + return blessed($obj) + && blessed($obj) ne 'Regexp' + && all { $obj->can($_) } @methods; + }; +} + +sub create_child_type { + my ($self, @args) = @_; + return Moose::Meta::TypeConstraint->new(@args, parent => $self); +} + +sub get_message { + my $self = shift; + my ($value) = @_; + + if ($self->has_message) { + return $self->SUPER::get_message(@_); + } + + my @methods = grep { !$value->can($_) } @{ $self->methods }; + my $class = blessed $value; + return $class + . " is missing methods " + . english_list(map { "'$_'" } @methods); +} + +1; + +__END__ + +=pod + +=head1 NAME + +Moose::Meta::TypeConstraint::DuckType - Type constraint for duck typing + +=head1 DESCRIPTION + +This class represents type constraints based on an enumerated list of +required methods. + +=head1 INHERITANCE + +C is a subclass of +L. + +=head1 METHODS + +=over 4 + +=item B<< Moose::Meta::TypeConstraint::DuckType->new(%options) >> + +This creates a new duck type constraint based on the given +C<%options>. + +It takes the same options as its parent, with several +exceptions. First, it requires an additional option, C. This +should be an array reference containing a list of required method +names. Second, it automatically sets the parent to the C type. + +Finally, it ignores any provided C option. The constraint +is generated automatically based on the provided C. + +=item B<< $constraint->methods >> + +Returns the array reference of required methods provided to the +constructor. + +=item B<< $constraint->create_child_type >> + +This returns a new L object with the type +as its parent. + +Note that it does I return a C +object! + +=back + +=head1 BUGS + +All complex software has bugs lurking in it, and this module is no +exception. If you find a bug please either email me, or add the bug +to cpan-RT. + +=head1 AUTHOR + +Chris Prather Echris@prather.orgE + +Shawn M Moore Esartak@gmail.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2009 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 5d65d30..7d7da3a 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -32,6 +32,7 @@ use Moose::Meta::TypeConstraint::Parameterizable; use Moose::Meta::TypeConstraint::Class; use Moose::Meta::TypeConstraint::Role; use Moose::Meta::TypeConstraint::Enum; +use Moose::Meta::TypeConstraint::DuckType; use Moose::Meta::TypeCoercion; use Moose::Meta::TypeCoercion::Union; use Moose::Meta::TypeConstraint::Registry; @@ -366,20 +367,9 @@ sub duck_type { } register_type_constraint( - _create_type_constraint( + create_duck_type_constraint( $type_name, - 'Object', - sub { - my $obj = $_; - return all { $obj->can($_) } @methods; - }, - sub { - my $obj = $_; - my $class = blessed($obj); - my @missing_methods = grep { !$obj->can($_) } @methods; - return - "$class is missing methods '@missing_methods'"; - }, + \@methods, ) ); } @@ -443,6 +433,15 @@ sub create_enum_type_constraint { ); } +sub create_duck_type_constraint { + my ( $type_name, $methods ) = @_; + + Moose::Meta::TypeConstraint::DuckType->new( + name => $type_name || '__ANON__', + methods => $methods, + ); +} + ## -------------------------------------------------------- ## desugaring functions ... ## -------------------------------------------------------- @@ -604,6 +603,7 @@ $_->make_immutable( Moose::Meta::TypeConstraint::Class Moose::Meta::TypeConstraint::Role Moose::Meta::TypeConstraint::Enum + Moose::Meta::TypeConstraint::DuckType Moose::Meta::TypeConstraint::Registry ); @@ -1178,6 +1178,11 @@ L constructor (as a hash). Given a enum name this function will create a new L object for that enum name. +=item B + +Given a duck type name this function will create a new +L object for that enum name. + =item B Given a type name, this first attempts to find a matching constraint