X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil%2FTypeConstraints.pm;h=2341102181010c48874dcf6469e16fc368aa0219;hb=e7597637a2d3c7fddf0e0ea651e3216f8c461c95;hp=a5e6e0f3030daa42252e07422dabd09742391e8d;hpb=3ee7b5ad664d6b70cb48914bda65cc5c9b905baa;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index a5e6e0f..2341102 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -6,7 +6,7 @@ use List::MoreUtils qw( all any ); use Scalar::Util qw( blessed reftype ); use Moose::Exporter; -our $VERSION = '0.80'; +our $VERSION = '0.91'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -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; @@ -45,7 +46,8 @@ Moose::Exporter->setup_import_methods( coerce from via enum find_type_constraint - register_type_constraint ) + register_type_constraint + match_on_type ) ], _export_to_main => 1, ); @@ -366,20 +368,9 @@ sub duck_type { } register_type_constraint( - _create_type_constraint( + create_duck_type_constraint( $type_name, - 'Object', - sub { - my $obj = $_; - return 0 unless all { $obj->can($_) } @methods; - return 1; - }, - sub { - my $obj = $_; - my @missing_methods = grep { !$obj->can($_) } @methods; - return - "${\blessed($obj)} is missing methods '@missing_methods'"; - }, + \@methods, ) ); } @@ -443,6 +434,48 @@ 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, + ); +} + +sub match_on_type { + my ($to_match, @cases) = @_; + my $default; + if (@cases % 2 != 0) { + $default = pop @cases; + (ref $default eq 'CODE') + || __PACKAGE__->_throw_error("Default case must be a CODE ref, not $default"); + } + while (@cases) { + my ($type, $action) = splice @cases, 0, 2; + + unless (blessed $type && $type->isa('Moose::Meta::TypeConstraint')) { + $type = find_or_parse_type_constraint($type) + || __PACKAGE__->_throw_error("Cannot find or parse the type '$type'") + } + + (ref $action eq 'CODE') + || __PACKAGE__->_throw_error("Match action must be a CODE ref, not $action"); + + if ($type->check($to_match)) { + local $_ = $to_match; + return $action->($to_match); + } + } + (defined $default) + || __PACKAGE__->_throw_error("No cases matched for $to_match"); + { + local $_ = $to_match; + return $default->($to_match); + } +} + + ## -------------------------------------------------------- ## desugaring functions ... ## -------------------------------------------------------- @@ -604,6 +637,7 @@ $_->make_immutable( Moose::Meta::TypeConstraint::Class Moose::Meta::TypeConstraint::Role Moose::Meta::TypeConstraint::Enum + Moose::Meta::TypeConstraint::DuckType Moose::Meta::TypeConstraint::Registry ); @@ -657,6 +691,7 @@ subtype 'Object' => as 'Ref' => where { blessed($_) && blessed($_) ne 'Regexp' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Object; +# This type is deprecated. subtype 'Role' => as 'Object' => where { $_->can('does') } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Role; @@ -848,10 +883,10 @@ that hierarchy represented visually. Defined Value Num - Int + Int Str - ClassName - RoleName + ClassName + RoleName Ref ScalarRef ArrayRef[`a] @@ -859,9 +894,8 @@ that hierarchy represented visually. CodeRef RegexpRef GlobRef - FileHandle + FileHandle Object - Role B Any type followed by a type parameter C<[`a]> can be parameterized, this means you can say: @@ -887,8 +921,7 @@ existence check. This means that your class B be loaded for this type constraint to pass. B The C constraint checks a string is a I which is a role, like C<'MyApp::Role::Comparable'>. The C -constraint checks that an I the named role. +name> which is a role, like C<'MyApp::Role::Comparable'>. =head2 Type Constraint Naming @@ -1068,7 +1101,7 @@ B You should only use this if you know what you are doing, all the built in types use this, so your subtypes (assuming they are shallow) will not likely need to use this. -=item B where { } ... > +=item B<< type 'Name' => where { } ... >> This creates a base type, which has no parent. @@ -1082,6 +1115,68 @@ The valid hashref keys are C, C, and C. =back +=head2 Type Constraint Utilities + +=over 4 + +=item B<< match_on_type $value => ( $type => \&action, ... ?\&default ) >> + +This is a utility function for doing simple type based dispatching +similar to match/case in O'Caml and case/of in Haskell. It does not +claim to be as featureful as either of those and does not support any +kind of automatic destructuring bind. However it is suitable for a fair +amount of your dispatching needs, for instance, here is a simple +Perl pretty printer dispatching over the core Moose types. + + sub ppprint { + my $x = shift; + match_on_type $x => + HashRef => sub { + my $hash = shift; + '{ ' . (join ", " => map { + $_ . ' => ' . ppprint( $hash->{ $_ } ) + } sort keys %$hash ) . ' }' }, + ArrayRef => sub { + my $array = shift; + '[ '.(join ", " => map { ppprint( $_ ) } @$array ).' ]' }, + CodeRef => sub { 'sub { ... }' }, + RegexpRef => sub { 'qr/' . $_ . '/' }, + GlobRef => sub { '*' . B::svref_2object($_)->NAME }, + Object => sub { $_->can('to_string') ? $_->to_string : $_ }, + ScalarRef => sub { '\\' . ppprint( ${$_} ) }, + Num => sub { $_ }, + Str => sub { '"'. $_ . '"' }, + Undef => sub { 'undef' }, + => sub { die "I don't know what $_ is" }; + } + +Or a simple JSON serializer: + + sub to_json { + my $x = shift; + match_on_type $x => + HashRef => sub { + my $hash = shift; + '{ ' . (join ", " => map { + '"' . $_ . '" : ' . to_json( $hash->{ $_ } ) + } sort keys %$hash ) . ' }' }, + ArrayRef => sub { + my $array = shift; + '[ ' . (join ", " => map { to_json( $_ ) } @$array ) . ' ]' }, + Num => sub { $_ }, + Str => sub { '"'. $_ . '"' }, + Undef => sub { 'null' }, + => sub { die "$_ is not acceptable json type" }; + } + +Based on a mapping of C<$type> to C<\&action>, where C<$type> can be +either a string type or a L object, and +C<\&action> is a CODE ref, this function will dispatch on the first +match for C<$value>. It is possible to have a catch-all at the end +in the form of a C<\&default> CODE ref. + +=back + =head2 Type Coercion Constructors You can define coercions for type constraints, which allow you to @@ -1178,6 +1273,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