add duck_type to Moose::Util::TypeConstraints
Chris Prather [Fri, 27 Mar 2009 21:09:13 +0000 (17:09 -0400)]
this will subtype Object and check to be sure the value ->can() a list of methods

lib/Moose/Util/TypeConstraints.pm
t/040_type_constraints/034_duck_types.t [new file with mode: 0644]

index d6f8ebb..97f5669 100644 (file)
@@ -9,7 +9,7 @@ use List::MoreUtils qw( all any );
 use Scalar::Util qw( blessed reftype );
 use Moose::Exporter;
 
-our $VERSION   = '0.73';
+our $VERSION = '0.73';
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
 
@@ -21,9 +21,9 @@ our $AUTHORITY = 'cpan:STEVAN';
 # compiled.
 
 # dah sugah!
-sub where       (&);
-sub via         (&);
-sub message     (&);
+sub where (&);
+sub via (&);
+sub message (&);
 sub optimize_as (&);
 
 ## --------------------------------------------------------
@@ -43,7 +43,7 @@ use Moose::Util::TypeConstraints::OptimizedConstraints;
 Moose::Exporter->setup_import_methods(
     as_is => [
         qw(
-            type subtype class_type role_type maybe_type
+            type subtype class_type role_type maybe_type duck_type
             as where message optimize_as
             coerce from via
             enum
@@ -59,55 +59,63 @@ Moose::Exporter->setup_import_methods(
 
 my $REGISTRY = Moose::Meta::TypeConstraint::Registry->new;
 
-sub get_type_constraint_registry         { $REGISTRY }
-sub list_all_type_constraints            { keys %{$REGISTRY->type_constraints} }
+sub get_type_constraint_registry {$REGISTRY}
+sub list_all_type_constraints    { keys %{ $REGISTRY->type_constraints } }
+
 sub export_type_constraints_as_functions {
     my $pkg = caller();
     no strict 'refs';
-    foreach my $constraint (keys %{$REGISTRY->type_constraints}) {
-        my $tc = $REGISTRY->get_type_constraint($constraint)->_compiled_type_constraint;
-        *{"${pkg}::${constraint}"} = sub { $tc->($_[0]) ? 1 : undef }; # the undef is for compat
+    foreach my $constraint ( keys %{ $REGISTRY->type_constraints } ) {
+        my $tc = $REGISTRY->get_type_constraint($constraint)
+            ->_compiled_type_constraint;
+        *{"${pkg}::${constraint}"}
+            = sub { $tc->( $_[0] ) ? 1 : undef };    # the undef is for compat
     }
 }
 
 sub create_type_constraint_union {
     my @type_constraint_names;
 
-    if (scalar @_ == 1 && _detect_type_constraint_union($_[0])) {
-        @type_constraint_names = _parse_type_constraint_union($_[0]);
+    if ( scalar @_ == 1 && _detect_type_constraint_union( $_[0] ) ) {
+        @type_constraint_names = _parse_type_constraint_union( $_[0] );
     }
     else {
         @type_constraint_names = @_;
     }
-    
-    (scalar @type_constraint_names >= 2)
-        || __PACKAGE__->_throw_error("You must pass in at least 2 type names to make a union");
+
+    ( scalar @type_constraint_names >= 2 )
+        || __PACKAGE__->_throw_error(
+        "You must pass in at least 2 type names to make a union");
 
     my @type_constraints = map {
-        find_or_parse_type_constraint($_) ||
-         __PACKAGE__->_throw_error("Could not locate type constraint ($_) for the union");
+        find_or_parse_type_constraint($_)
+            || __PACKAGE__->_throw_error(
+            "Could not locate type constraint ($_) for the union");
     } @type_constraint_names;
 
     return Moose::Meta::TypeConstraint::Union->new(
-        type_constraints => \@type_constraints
-    );
+        type_constraints => \@type_constraints );
 }
 
 sub create_parameterized_type_constraint {
     my $type_constraint_name = shift;
-    my ($base_type, $type_parameter) = _parse_parameterized_type_constraint($type_constraint_name);
+    my ( $base_type, $type_parameter )
+        = _parse_parameterized_type_constraint($type_constraint_name);
 
-    (defined $base_type && defined $type_parameter)
-        || __PACKAGE__->_throw_error("Could not parse type name ($type_constraint_name) correctly");
+    ( defined $base_type && defined $type_parameter )
+        || __PACKAGE__->_throw_error(
+        "Could not parse type name ($type_constraint_name) correctly");
 
-    if ($REGISTRY->has_type_constraint($base_type)) {
+    if ( $REGISTRY->has_type_constraint($base_type) ) {
         my $base_type_tc = $REGISTRY->get_type_constraint($base_type);
         return _create_parameterized_type_constraint(
             $base_type_tc,
             $type_parameter
         );
-    } else {
-        __PACKAGE__->_throw_error("Could not locate the base type ($base_type)");
+    }
+    else {
+        __PACKAGE__->_throw_error(
+            "Could not locate the base type ($base_type)");
     }
 }
 
@@ -115,22 +123,24 @@ sub _create_parameterized_type_constraint {
     my ( $base_type_tc, $type_parameter ) = @_;
     if ( $base_type_tc->can('parameterize') ) {
         return $base_type_tc->parameterize($type_parameter);
-    } else {
+    }
+    else {
         return Moose::Meta::TypeConstraint::Parameterized->new(
-            name => $base_type_tc->name . '[' . $type_parameter . ']',
+            name   => $base_type_tc->name . '[' . $type_parameter . ']',
             parent => $base_type_tc,
-            type_parameter => find_or_create_isa_type_constraint($type_parameter),
+            type_parameter =>
+                find_or_create_isa_type_constraint($type_parameter),
         );
     }
-}                                       
+}
 
 #should we also support optimized checks?
 sub create_class_type_constraint {
     my ( $class, $options ) = @_;
 
-    # too early for this check
-    #find_type_constraint("ClassName")->check($class)
-    #    || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name");
+# too early for this check
+#find_type_constraint("ClassName")->check($class)
+#    || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name");
 
     my %options = (
         class => $class,
@@ -140,15 +150,15 @@ sub create_class_type_constraint {
 
     $options{name} ||= "__ANON__";
 
-    Moose::Meta::TypeConstraint::Class->new( %options );
+    Moose::Meta::TypeConstraint::Class->new(%options);
 }
 
 sub create_role_type_constraint {
     my ( $role, $options ) = @_;
 
-    # too early for this check
-    #find_type_constraint("ClassName")->check($class)
-    #    || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name");
+# too early for this check
+#find_type_constraint("ClassName")->check($class)
+#    || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name");
 
     my %options = (
         role => $role,
@@ -158,17 +168,18 @@ sub create_role_type_constraint {
 
     $options{name} ||= "__ANON__";
 
-    Moose::Meta::TypeConstraint::Role->new( %options );
+    Moose::Meta::TypeConstraint::Role->new(%options);
 }
 
-
 sub find_or_create_type_constraint {
     my ( $type_constraint_name, $options_for_anon_type ) = @_;
 
-    if ( my $constraint = find_or_parse_type_constraint($type_constraint_name) ) {
+    if ( my $constraint
+        = find_or_parse_type_constraint($type_constraint_name) ) {
         return $constraint;
     }
     elsif ( defined $options_for_anon_type ) {
+
         # NOTE:
         # if there is no $options_for_anon_type
         # specified, then we assume they don't
@@ -191,25 +202,31 @@ sub find_or_create_type_constraint {
 
 sub find_or_create_isa_type_constraint {
     my $type_constraint_name = shift;
-    find_or_parse_type_constraint($type_constraint_name) || create_class_type_constraint($type_constraint_name)
+    find_or_parse_type_constraint($type_constraint_name)
+        || create_class_type_constraint($type_constraint_name);
 }
 
 sub find_or_create_does_type_constraint {
     my $type_constraint_name = shift;
-    find_or_parse_type_constraint($type_constraint_name) || create_role_type_constraint($type_constraint_name)
+    find_or_parse_type_constraint($type_constraint_name)
+        || create_role_type_constraint($type_constraint_name);
 }
 
 sub find_or_parse_type_constraint {
     my $type_constraint_name = normalize_type_constraint_name(shift);
     my $constraint;
-    
-    if ($constraint = find_type_constraint($type_constraint_name)) {
+
+    if ( $constraint = find_type_constraint($type_constraint_name) ) {
         return $constraint;
-    } elsif (_detect_type_constraint_union($type_constraint_name)) {
+    }
+    elsif ( _detect_type_constraint_union($type_constraint_name) ) {
         $constraint = create_type_constraint_union($type_constraint_name);
-    } elsif (_detect_parameterized_type_constraint($type_constraint_name)) {
-        $constraint = create_parameterized_type_constraint($type_constraint_name);
-    } else {
+    }
+    elsif ( _detect_parameterized_type_constraint($type_constraint_name) ) {
+        $constraint
+            = create_parameterized_type_constraint($type_constraint_name);
+    }
+    else {
         return;
     }
 
@@ -248,7 +265,8 @@ sub find_type_constraint {
 
 sub register_type_constraint {
     my $constraint = shift;
-    __PACKAGE__->_throw_error("can't register an unnamed type constraint") unless defined $constraint->name;
+    __PACKAGE__->_throw_error("can't register an unnamed type constraint")
+        unless defined $constraint->name;
     $REGISTRY->add_type_constraint($constraint);
     return $constraint;
 }
@@ -256,8 +274,9 @@ sub register_type_constraint {
 # type constructors
 
 sub type {
+
     # back-compat version, called without sugar
-    if ( ! any { ( reftype($_) || '' ) eq 'HASH' } @_ ) {
+    if ( !any { ( reftype($_) || '' ) eq 'HASH' } @_ ) {
         return _create_type_constraint( $_[0], undef, $_[1] );
     }
 
@@ -265,10 +284,14 @@ sub type {
 
     my %p = map { %{$_} } @_;
 
-    return _create_type_constraint( $name, undef, $p{where}, $p{message}, $p{optimize_as} );
+    return _create_type_constraint(
+        $name, undef, $p{where}, $p{message},
+        $p{optimize_as}
+    );
 }
 
 sub subtype {
+
     # crazy back-compat code for being called without sugar ...
     #
     # subtype 'Parent', sub { where };
@@ -279,7 +302,7 @@ sub subtype {
     # subtype 'Parent', sub { where }, sub { message };
     # subtype 'Parent', sub { where }, sub { message }, sub { optimized };
     if ( scalar @_ >= 3 && all { ( reftype($_) || '' ) eq 'CODE' }
-         @_[ 1 .. $#_ ] ) {
+        @_[ 1 .. $#_ ] ) {
         return _create_type_constraint( undef, @_ );
     }
 
@@ -288,30 +311,35 @@ sub subtype {
         return _create_type_constraint(@_);
     }
 
-    if ( @_ == 1 && ! ref $_[0] ) {
-        __PACKAGE__->_throw_error('A subtype cannot consist solely of a name, it must have a parent');
+    if ( @_ == 1 && !ref $_[0] ) {
+        __PACKAGE__->_throw_error(
+            'A subtype cannot consist solely of a name, it must have a parent'
+        );
     }
 
     # The blessed check is mostly to accommodate MooseX::Types, which
     # uses an object which overloads stringification as a type name.
-    my $name = ref $_[0] && ! blessed $_[0] ? undef : shift;
+    my $name = ref $_[0] && !blessed $_[0] ? undef : shift;
 
     my %p = map { %{$_} } @_;
 
     # subtype Str => where { ... };
-    if ( ! exists $p{as} ) {
+    if ( !exists $p{as} ) {
         $p{as} = $name;
         $name = undef;
     }
 
-    return _create_type_constraint( $name, $p{as}, $p{where}, $p{message}, $p{optimize_as} );
+    return _create_type_constraint(
+        $name, $p{as}, $p{where}, $p{message},
+        $p{optimize_as}
+    );
 }
 
 sub class_type {
     register_type_constraint(
         create_class_type_constraint(
             $_[0],
-            ( defined($_[1]) ? $_[1] : () ),
+            ( defined( $_[1] ) ? $_[1] : () ),
         )
     );
 }
@@ -320,7 +348,7 @@ sub role_type ($;$) {
     register_type_constraint(
         create_role_type_constraint(
             $_[0],
-            ( defined($_[1]) ? $_[1] : () ),
+            ( defined( $_[1] ) ? $_[1] : () ),
         )
     );
 }
@@ -333,9 +361,34 @@ sub maybe_type {
     );
 }
 
+sub duck_type {
+    my ($type_name, @methods) = @_;
+    if ( ref $type_name eq 'ARRAY' && !@methods ) {
+        @methods    = @$type_name;
+        $type_name = undef;
+    }
+
+    register_type_constraint(
+        _create_type_constraint(
+            $type_name, 'Object',
+            sub {
+                my $obj = $_;
+                my @missing_methods = grep { !$obj->can($_) } @methods;
+                return ! scalar @missing_methods;
+            },
+            sub {
+                my $obj = $_;
+                my @missing_methods = grep { !$obj->can($_) } @methods;
+                return
+                    "${\blessed($obj)} is missing methods '@missing_methods'";
+            },
+        )
+    );
+}
+
 sub coerce {
-    my ($type_name, @coercion_map) = @_;
-    _install_type_coercions($type_name, \@coercion_map);
+    my ( $type_name, @coercion_map ) = @_;
+    _install_type_coercions( $type_name, \@coercion_map );
 }
 
 # The trick of returning @_ lets us avoid having to specify a
@@ -351,7 +404,7 @@ sub coerce {
 #
 # If as() returns all it's extra arguments, this just works, and
 # preserves backwards compatibility.
-sub as              { { as          => shift }, @_ }
+sub as { { as => shift }, @_ }
 sub where (&)       { { where       => $_[0] } }
 sub message (&)     { { message     => $_[0] } }
 sub optimize_as (&) { { optimize_as => $_[0] } }
@@ -360,17 +413,19 @@ sub from    {@_}
 sub via (&) { $_[0] }
 
 sub enum {
-    my ($type_name, @values) = @_;
+    my ( $type_name, @values ) = @_;
+
     # NOTE:
     # if only an array-ref is passed then
     # you get an anon-enum
     # - SL
-    if (ref $type_name eq 'ARRAY' && !@values) {
+    if ( ref $type_name eq 'ARRAY' && !@values ) {
         @values    = @$type_name;
         $type_name = undef;
     }
-    (scalar @values >= 2)
-        || __PACKAGE__->_throw_error("You must have at least two values to enumerate through");
+    ( scalar @values >= 2 )
+        || __PACKAGE__->_throw_error(
+        "You must have at least two values to enumerate through");
     my %valid = map { $_ => 1 } @values;
 
     register_type_constraint(
@@ -385,7 +440,7 @@ sub create_enum_type_constraint {
     my ( $type_name, $values ) = @_;
 
     Moose::Meta::TypeConstraint::Enum->new(
-        name   => $type_name || '__ANON__',
+        name => $type_name || '__ANON__',
         values => $values,
     );
 }
@@ -429,10 +484,13 @@ sub _create_type_constraint ($$$;$$) {
     );
 
     my $constraint;
-    if ( defined $parent
+    if (
+        defined $parent
         and $parent
-        = blessed $parent ? $parent : find_or_create_isa_type_constraint($parent) )
-    {
+        = blessed $parent
+        ? $parent
+        : find_or_create_isa_type_constraint($parent)
+        ) {
         $constraint = $parent->create_child_type(%opts);
     }
     else {
@@ -446,11 +504,12 @@ sub _create_type_constraint ($$$;$$) {
 }
 
 sub _install_type_coercions ($$) {
-    my ($type_name, $coercion_map) = @_;
+    my ( $type_name, $coercion_map ) = @_;
     my $type = find_type_constraint($type_name);
-    (defined $type)
-        || __PACKAGE__->_throw_error("Cannot find type '$type_name', perhaps you forgot to load it.");
-    if ($type->has_coercion) {
+    ( defined $type )
+        || __PACKAGE__->_throw_error(
+        "Cannot find type '$type_name', perhaps you forgot to load it.");
+    if ( $type->has_coercion ) {
         $type->coercion->add_type_coercions(@$coercion_map);
     }
     else {
@@ -467,6 +526,7 @@ sub _install_type_coercions ($$) {
 ## --------------------------------------------------------
 
 {
+
     # All I have to say is mugwump++ cause I know
     # do not even have enough regexp-fu to be able
     # to have written this (I can only barely
@@ -480,9 +540,11 @@ sub _install_type_coercions ($$) {
 
     my $any;
 
-    my $type                = qr{  $valid_chars+  (?: \[ \s* (??{$any})   \s* \] )? }x;
-    my $type_capture_parts  = qr{ ($valid_chars+) (?: \[ \s* ((??{$any})) \s* \] )? }x;
-    my $type_with_parameter = qr{  $valid_chars+      \[ \s* (??{$any})   \s* \]    }x;
+    my $type = qr{  $valid_chars+  (?: \[ \s* (??{$any})   \s* \] )? }x;
+    my $type_capture_parts
+        = qr{ ($valid_chars+) (?: \[ \s* ((??{$any})) \s* \] )? }x;
+    my $type_with_parameter
+        = qr{  $valid_chars+      \[ \s* (??{$any})   \s* \]    }x;
 
     my $op_union = qr{ \s* \| \s* }x;
     my $union    = qr{ $type (?: $op_union $type )+ }x;
@@ -490,34 +552,34 @@ sub _install_type_coercions ($$) {
     $any = qr{ $type | $union }x;
 
     sub _parse_parameterized_type_constraint {
-        { no warnings 'void'; $any; } # force capture of interpolated lexical
+        { no warnings 'void'; $any; }  # force capture of interpolated lexical
         $_[0] =~ m{ $type_capture_parts }x;
-        return ($1, $2);
+        return ( $1, $2 );
     }
 
     sub _detect_parameterized_type_constraint {
-        { no warnings 'void'; $any; } # force capture of interpolated lexical
+        { no warnings 'void'; $any; }  # force capture of interpolated lexical
         $_[0] =~ m{ ^ $type_with_parameter $ }x;
     }
 
     sub _parse_type_constraint_union {
-        { no warnings 'void'; $any; } # force capture of interpolated lexical
+        { no warnings 'void'; $any; }  # force capture of interpolated lexical
         my $given = shift;
         my @rv;
         while ( $given =~ m{ \G (?: $op_union )? ($type) }gcx ) {
             push @rv => $1;
         }
-        (pos($given) eq length($given))
-            || __PACKAGE__->_throw_error("'$given' didn't parse (parse-pos="
-                     . pos($given)
-                     . " and str-length="
-                     . length($given)
-                     . ")");
+        ( pos($given) eq length($given) )
+            || __PACKAGE__->_throw_error( "'$given' didn't parse (parse-pos="
+                . pos($given)
+                . " and str-length="
+                . length($given)
+                . ")" );
         @rv;
     }
 
     sub _detect_type_constraint_union {
-        { no warnings 'void'; $any; } # force capture of interpolated lexical
+        { no warnings 'void'; $any; }  # force capture of interpolated lexical
         $_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x;
     }
 }
@@ -547,115 +609,112 @@ $_->make_immutable(
     Moose::Meta::TypeConstraint::Registry
 );
 
-type 'Any'  => where { 1 }; # meta-type including all
-type 'Item' => where { 1 }; # base-type
+type 'Any'  => where {1};    # meta-type including all
+type 'Item' => where {1};    # base-type
 
 subtype 'Undef'   => as 'Item' => where { !defined($_) };
-subtype 'Defined' => as 'Item' => where {  defined($_) };
-
-subtype 'Bool'
-    => as 'Item'
-    => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' };
-
-subtype 'Value'
-    => as 'Defined'
-    => where { !ref($_) }
-    => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Value;
-
-subtype 'Ref'
-    => as 'Defined'
-    => where {  ref($_) }
-    => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Ref;
-
-subtype 'Str'
-    => as 'Value'
-    => where { 1 }
-    => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Str;
-
-subtype 'Num'
-    => as 'Value'
-    => where { Scalar::Util::looks_like_number($_) }
-    => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Num;
-
-subtype 'Int'
-    => as 'Num'
-    => where { "$_" =~ /^-?[0-9]+$/ }
-    => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Int;
-
-subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::ScalarRef;
-subtype 'CodeRef'   => as 'Ref' => where { ref($_) eq 'CODE'   } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::CodeRef;
-subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef;
-subtype 'GlobRef'   => as 'Ref' => where { ref($_) eq 'GLOB'   } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::GlobRef;
+subtype 'Defined' => as 'Item' => where { defined($_) };
+
+subtype 'Bool' => as 'Item' =>
+    where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' };
+
+subtype 'Value' => as 'Defined' => where { !ref($_) } =>
+    optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Value;
+
+subtype 'Ref' => as 'Defined' => where { ref($_) } =>
+    optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Ref;
+
+subtype 'Str' => as 'Value' => where {1} =>
+    optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Str;
+
+subtype 'Num' => as 'Value' =>
+    where { Scalar::Util::looks_like_number($_) } =>
+    optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Num;
+
+subtype 'Int' => as 'Num' => where { "$_" =~ /^-?[0-9]+$/ } =>
+    optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Int;
+
+subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' } =>
+    optimize_as
+    \&Moose::Util::TypeConstraints::OptimizedConstraints::ScalarRef;
+subtype 'CodeRef' => as 'Ref' => where { ref($_) eq 'CODE' } =>
+    optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::CodeRef;
+subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' } =>
+    optimize_as
+    \&Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef;
+subtype 'GlobRef' => as 'Ref' => where { ref($_) eq 'GLOB' } =>
+    optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::GlobRef;
 
 # NOTE:
 # scalar filehandles are GLOB refs,
 # but a GLOB ref is not always a filehandle
-subtype 'FileHandle'
-    => as 'GlobRef'
-    => where { Scalar::Util::openhandle($_) || ( blessed($_) && $_->isa("IO::Handle") ) }
-    => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::FileHandle;
+subtype 'FileHandle' => as 'GlobRef' => where {
+    Scalar::Util::openhandle($_) || ( blessed($_) && $_->isa("IO::Handle") );
+} => optimize_as
+    \&Moose::Util::TypeConstraints::OptimizedConstraints::FileHandle;
 
 # NOTE:
 # blessed(qr/.../) returns true,.. how odd
-subtype 'Object'
-    => as 'Ref'
-    => where { blessed($_) && blessed($_) ne 'Regexp' }
-    => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Object;
+subtype 'Object' => as 'Ref' =>
+    where { blessed($_) && blessed($_) ne 'Regexp' } =>
+    optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Object;
 
-subtype 'Role'
-    => as 'Object'
-    => where { $_->can('does') }
-    => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Role;
+subtype 'Role' => as 'Object' => where { $_->can('does') } =>
+    optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Role;
 
-my $_class_name_checker = sub {};
+my $_class_name_checker = sub { };
 
-subtype 'ClassName'
-    => as 'Str'
-    => where { Class::MOP::is_class_loaded($_) }
-    => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::ClassName;
+subtype 'ClassName' => as 'Str' =>
+    where { Class::MOP::is_class_loaded($_) } => optimize_as
+    \&Moose::Util::TypeConstraints::OptimizedConstraints::ClassName;
 
-subtype 'RoleName'
-    => as 'ClassName'
-    => where { (($_->can('meta') || return)->($_) || return)->isa('Moose::Meta::Role') }
-    => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::RoleName;    ;
+subtype 'RoleName' => as 'ClassName' => where {
+    ( ( $_->can('meta') || return )->($_) || return )
+        ->isa('Moose::Meta::Role');
+} => optimize_as
+    \&Moose::Util::TypeConstraints::OptimizedConstraints::RoleName;
 
 ## --------------------------------------------------------
 # parameterizable types ...
 
 $REGISTRY->add_type_constraint(
     Moose::Meta::TypeConstraint::Parameterizable->new(
-        name                 => 'ArrayRef',
-        package_defined_in   => __PACKAGE__,
-        parent               => find_type_constraint('Ref'),
-        constraint           => sub { ref($_) eq 'ARRAY'  },
-        optimized            => \&Moose::Util::TypeConstraints::OptimizedConstraints::ArrayRef,
+        name               => 'ArrayRef',
+        package_defined_in => __PACKAGE__,
+        parent             => find_type_constraint('Ref'),
+        constraint         => sub { ref($_) eq 'ARRAY' },
+        optimized =>
+            \&Moose::Util::TypeConstraints::OptimizedConstraints::ArrayRef,
         constraint_generator => sub {
             my $type_parameter = shift;
-            my $check = $type_parameter->_compiled_type_constraint;
+            my $check          = $type_parameter->_compiled_type_constraint;
             return sub {
                 foreach my $x (@$_) {
-                    ($check->($x)) || return
-                } 1;
-            }
+                    ( $check->($x) ) || return;
+                }
+                1;
+                }
         }
     )
 );
 
 $REGISTRY->add_type_constraint(
     Moose::Meta::TypeConstraint::Parameterizable->new(
-        name                 => 'HashRef',
-        package_defined_in   => __PACKAGE__,
-        parent               => find_type_constraint('Ref'),
-        constraint           => sub { ref($_) eq 'HASH'  },
-        optimized            => \&Moose::Util::TypeConstraints::OptimizedConstraints::HashRef,
+        name               => 'HashRef',
+        package_defined_in => __PACKAGE__,
+        parent             => find_type_constraint('Ref'),
+        constraint         => sub { ref($_) eq 'HASH' },
+        optimized =>
+            \&Moose::Util::TypeConstraints::OptimizedConstraints::HashRef,
         constraint_generator => sub {
             my $type_parameter = shift;
-            my $check = $type_parameter->_compiled_type_constraint;
+            my $check          = $type_parameter->_compiled_type_constraint;
             return sub {
-                foreach my $x (values %$_) {
-                    ($check->($x)) || return
-                } 1;
-            }
+                foreach my $x ( values %$_ ) {
+                    ( $check->($x) ) || return;
+                }
+                1;
+                }
         }
     )
 );
@@ -665,27 +724,30 @@ $REGISTRY->add_type_constraint(
         name                 => 'Maybe',
         package_defined_in   => __PACKAGE__,
         parent               => find_type_constraint('Item'),
-        constraint           => sub { 1 },
+        constraint           => sub {1},
         constraint_generator => sub {
             my $type_parameter = shift;
-            my $check = $type_parameter->_compiled_type_constraint;
+            my $check          = $type_parameter->_compiled_type_constraint;
             return sub {
-                return 1 if not(defined($_)) || $check->($_);
+                return 1 if not( defined($_) ) || $check->($_);
                 return;
-            }
+                }
         }
     )
 );
 
-my @PARAMETERIZABLE_TYPES = map {
-    $REGISTRY->get_type_constraint($_)
-} qw[ArrayRef HashRef Maybe];
+my @PARAMETERIZABLE_TYPES
+    = map { $REGISTRY->get_type_constraint($_) } qw[ArrayRef HashRef Maybe];
+
+sub get_all_parameterizable_types {@PARAMETERIZABLE_TYPES}
 
-sub get_all_parameterizable_types { @PARAMETERIZABLE_TYPES }
 sub add_parameterizable_type {
     my $type = shift;
-    (blessed $type && $type->isa('Moose::Meta::TypeConstraint::Parameterizable'))
-        || __PACKAGE__->_throw_error("Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type");
+    ( blessed $type
+            && $type->isa('Moose::Meta::TypeConstraint::Parameterizable') )
+        || __PACKAGE__->_throw_error(
+        "Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type"
+        );
     push @PARAMETERIZABLE_TYPES => $type;
 }
 
@@ -695,7 +757,7 @@ sub add_parameterizable_type {
 
 {
     my @BUILTINS = list_all_type_constraints();
-    sub list_all_builtin_type_constraints { @BUILTINS }
+    sub list_all_builtin_type_constraints {@BUILTINS}
 }
 
 sub _throw_error {
diff --git a/t/040_type_constraints/034_duck_types.t b/t/040_type_constraints/034_duck_types.t
new file mode 100644 (file)
index 0000000..a402ddb
--- /dev/null
@@ -0,0 +1,72 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use Test::More qw(no_plan);
+use Test::Exception;
+
+{
+
+    package Duck;
+    use Moose;
+
+    sub quack { }
+
+}
+
+{
+
+    package Swan;
+    use Moose;
+
+    sub honk { }
+
+}
+
+{
+
+    package RubberDuck;
+    use Moose;
+
+    sub quack { }
+
+}
+
+{
+
+    package DucktypeTest;
+    use Moose;
+    use Moose::Util::TypeConstraints;
+
+    duck_type 'DuckType' => qw(quack);
+
+    has duck => (
+        isa        => 'DuckType',
+        is => 'ro',
+        lazy_build => 1,
+    );
+
+    sub _build_duck { Duck->new }
+
+    has swan => (
+        isa => duck_type( [qw(honk)] ),
+        is => 'ro',
+    );
+
+}
+
+# try giving it a duck
+lives_ok { DucktypeTest->new( duck => Duck->new ) } 'the Duck lives okay';
+
+# try giving it a swan which is like a duck, but not close enough
+throws_ok { DucktypeTest->new( duck => Swan->new ) }
+qr/Swan is missing methods 'quack'/,
+    "the Swan doesn't quack";
+
+# try giving it a rubber RubberDuckey
+lives_ok { DucktypeTest->new( swan => Swan->new ) } 'but a Swan can honk';
+
+# try giving it a rubber RubberDuckey
+lives_ok { DucktypeTest->new( duck => RubberDuck->new ) }
+'the RubberDuck lives okay';
+