use warnings;
use metaclass;
+use B;
use Scalar::Util 'blessed';
use List::MoreUtils qw(all);
use Moose::Util 'english_list';
use Moose::Util::TypeConstraints ();
-our $VERSION = '1.03';
-$VERSION = eval $VERSION;
-our $AUTHORITY = 'cpan:STEVAN';
-
use base 'Moose::Meta::TypeConstraint';
__PACKAGE__->meta->add_attribute('methods' => (
accessor => 'methods',
));
+my $inliner = sub {
+ my $self = shift;
+ my $val = shift;
+
+ return 'Scalar::Util::blessed(' . $val . ') '
+ . '&& Scalar::Util::blessed(' . $val . ') ne "Regexp" '
+ . '&& &List::MoreUtils::all('
+ . 'sub { ' . $val . '->can($_) }, '
+ . join(', ', map { B::perlstring($_) } @{ $self->methods })
+ . ')';
+};
+
sub new {
my ( $class, %args ) = @_;
- $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Object');
+ $args{parent}
+ = Moose::Util::TypeConstraints::find_type_constraint('Object');
+
+ my @methods = @{ $args{methods} };
+ $args{constraint} = sub {
+ blessed( $_[0] ) ne 'Regexp'
+ && all { $_[0]->can($_) } @methods;
+ };
+
+ $args{inlined} = $inliner;
my $self = $class->_new(\%args);
};
}
-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);
1;
+# ABSTRACT: Type constraint for duck typing
+
__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
See L<Moose/BUGS> for details on reporting bugs.
-=head1 AUTHOR
-
-Chris Prather E<lt>chris@prather.orgE<gt>
-
-Shawn M Moore E<lt>sartak@gmail.comE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2006-2010 by Infinity Interactive, Inc.
-
-L<http://www.iinteractive.com>
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
=cut