X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil%2FTypeConstraints.pm;h=06733dfbc70b529e6a1239fe4caf3897ef4d5e81;hb=2ae1457eead0263b687bd59cd3630b893618e551;hp=b0ecf5cc8aa40960210685f42255b7c8a4a0a73f;hpb=113d3174264db82cb788bc846f617584072cba39;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index b0ecf5c..06733df 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.91'; +our $VERSION = '0.95'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -46,9 +46,9 @@ 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, ); ## -------------------------------------------------------- @@ -365,6 +365,9 @@ sub duck_type { @methods = @$type_name; $type_name = undef; } + if ( @methods == 1 && ref $methods[0] eq 'ARRAY' ) { + @methods = @{ $methods[0] }; + } register_type_constraint( create_duck_type_constraint( @@ -411,6 +414,9 @@ sub enum { @values = @$type_name; $type_name = undef; } + if ( @values == 1 && ref $values[0] eq 'ARRAY' ) { + @values = @{ $values[0] }; + } ( scalar @values >= 2 ) || __PACKAGE__->_throw_error( "You must have at least two values to enumerate through"); @@ -442,6 +448,39 @@ sub create_duck_type_constraint { ); } +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 ... ## -------------------------------------------------------- @@ -533,18 +572,19 @@ sub _install_type_coercions ($$) { use re "eval"; my $valid_chars = qr{[\w:\.]}; - my $type_atom = qr{ $valid_chars+ }; + my $type_atom = qr{ (?>$valid_chars+) }x; + my $ws = qr{ (?>\s*) }x; my $any; - my $type = qr{ $valid_chars+ (?: \[ \s* (??{$any}) \s* \] )? }x; + my $type = qr{ $type_atom (?: \[ $ws (??{$any}) $ws \] )? }x; my $type_capture_parts - = qr{ ($valid_chars+) (?: \[ \s* ((??{$any})) \s* \] )? }x; + = qr{ ($type_atom) (?: \[ $ws ((??{$any})) $ws \] )? }x; my $type_with_parameter - = qr{ $valid_chars+ \[ \s* (??{$any}) \s* \] }x; + = qr{ $type_atom \[ $ws (??{$any}) $ws \] }x; - my $op_union = qr{ \s* \| \s* }x; - my $union = qr{ $type (?: $op_union $type )+ }x; + my $op_union = qr{ $ws \| $ws }x; + my $union = qr{ $type (?> (?: $op_union $type )+ ) }x; $any = qr{ $type | $union }x; @@ -622,7 +662,7 @@ subtype 'Value' => as 'Defined' => where { !ref($_) } => subtype 'Ref' => as 'Defined' => where { ref($_) } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Ref; -subtype 'Str' => as 'Value' => where {1} => +subtype 'Str' => as 'Value' => where { ref(\$_) eq 'SCALAR' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Str; subtype 'Num' => as 'Str' => @@ -848,9 +888,9 @@ that hierarchy represented visually. Undef Defined Value - Num - Int Str + Num + Int ClassName RoleName Ref @@ -992,10 +1032,10 @@ metaclass L. Creates a type constraint for either C or something of the given type. -=item B +=item B This will create a subtype of Object and test to make sure the value -C do the methods in C<@methods>. +C do the methods in C<\@methods>. This is intended as an easy way to accept non-Moose objects that provide a certain interface. If you're using Moose classes, we @@ -1003,20 +1043,20 @@ recommend that you use a C-only Role instead. =item B -If passed an ARRAY reference instead of the C<$name>, C<@methods> -pair, this will create an unnamed duck type. This can be used in an -attribute definition like so: +If passed an ARRAY reference as the only parameter instead of the +C<$name>, C<\@methods> pair, this will create an unnamed duck type. +This can be used in an attribute definition like so: has 'cache' => ( is => 'ro', isa => duck_type( [qw( get_set )] ), ); -=item B +=item B This will create a basic subtype for a given set of strings. The resulting constraint will be a subtype of C and -will match any of the items in C<@values>. It is case sensitive. +will match any of the items in C<\@values>. It is case sensitive. See the L for a simple example. B This is not a true proper enum type, it is simply @@ -1024,9 +1064,9 @@ a convenient constraint builder. =item B -If passed an ARRAY reference instead of the C<$name>, C<@values> pair, -this will create an unnamed enum. This can then be used in an attribute -definition like so: +If passed an ARRAY reference as the only parameter instead of the +C<$name>, C<\@values> pair, this will create an unnamed enum. This +can then be used in an attribute definition like so: has 'sort_order' => ( is => 'ro', @@ -1081,6 +1121,78 @@ 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 OCaml and case/of in Haskell. It is not as featureful as those +languages, nor does not it support any kind of automatic destructuring +bind. 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" } + ); + } + +The matcher is done by mapping a C<$type> to an C<\&action>. The C<$type> can +be either a string type or a L object, and +C<\&action> is a subroutine reference. This function will dispatch on the +first match for C<$value>. It is possible to have a catch-all by providing an +additional subroutine reference as the final argument to C. + +=back + =head2 Type Coercion Constructors You can define coercions for type constraints, which allow you to @@ -1244,9 +1356,7 @@ Adds C<$type> to the list of parameterizable types =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. +See L for details on reporting bugs. =head1 AUTHOR @@ -1254,7 +1364,7 @@ Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE -Copyright 2006-2009 by Infinity Interactive, Inc. +Copyright 2006-2010 by Infinity Interactive, Inc. L