From: Chris Prather Date: Fri, 27 Mar 2009 21:09:13 +0000 (-0400) Subject: add duck_type to Moose::Util::TypeConstraints X-Git-Tag: 0.73_01~45^2~3 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=180899ed1783b4027d938a65a792e7083eaf447b;p=gitmo%2FMoose.git add duck_type to Moose::Util::TypeConstraints this will subtype Object and check to be sure the value ->can() a list of methods --- diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index d6f8ebb..97f5669 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -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 index 0000000..a402ddb --- /dev/null +++ b/t/040_type_constraints/034_duck_types.t @@ -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'; +