X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil%2FTypeConstraints.pm;h=71b32d7e27dde58e6cd25179f15c9a13e009f9b6;hb=b0f8f0ec76ec36c91de901ce9d848fa16b4c8f2b;hp=7d7da3a3a7cd1c1ad8f916361f9ae282e022d3d6;hpb=0a6bff54f187f41f2df406cc732d53b4d9100d59;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 7d7da3a..71b32d7 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -6,10 +6,6 @@ use List::MoreUtils qw( all any ); use Scalar::Util qw( blessed reftype ); use Moose::Exporter; -our $VERSION = '0.83'; -$VERSION = eval $VERSION; -our $AUTHORITY = 'cpan:STEVAN'; - ## -------------------------------------------------------- # Prototyped subs must be predeclared because we have a # circular dependency with Moose::Meta::Attribute et. al. @@ -25,6 +21,7 @@ sub optimize_as (&); ## -------------------------------------------------------- +use Moose::Deprecated; use Moose::Meta::TypeConstraint; use Moose::Meta::TypeConstraint::Union; use Moose::Meta::TypeConstraint::Parameterized; @@ -46,9 +43,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, ); ## -------------------------------------------------------- @@ -275,6 +272,12 @@ sub type { # back-compat version, called without sugar if ( !any { ( reftype($_) || '' ) eq 'HASH' } @_ ) { + Moose::Deprecated::deprecated( + feature => 'type without sugar', + message => + 'Calling type() with a simple list of parameters is deprecated' + ); + return _create_type_constraint( $_[0], undef, $_[1] ); } @@ -294,6 +297,12 @@ sub subtype { # # subtype 'Parent', sub { where }; if ( scalar @_ == 2 && ( reftype( $_[1] ) || '' ) eq 'CODE' ) { + Moose::Deprecated::deprecated( + feature => 'subtype without sugar', + message => + 'Calling subtype() with a simple list of parameters is deprecated' + ); + return _create_type_constraint( undef, @_ ); } @@ -301,11 +310,23 @@ sub subtype { # subtype 'Parent', sub { where }, sub { message }, sub { optimized }; if ( scalar @_ >= 3 && all { ( reftype($_) || '' ) eq 'CODE' } @_[ 1 .. $#_ ] ) { + Moose::Deprecated::deprecated( + feature => 'subtype without sugar', + message => + 'Calling subtype() with a simple list of parameters is deprecated' + ); + return _create_type_constraint( undef, @_ ); } # subtype 'Name', 'Parent', ... if ( scalar @_ >= 2 && all { !ref } @_[ 0, 1 ] ) { + Moose::Deprecated::deprecated( + feature => 'subtype without sugar', + message => + 'Calling subtype() with a simple list of parameters is deprecated' + ); + return _create_type_constraint(@_); } @@ -365,6 +386,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( @@ -407,14 +431,16 @@ sub enum { # 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 == 0 + || __PACKAGE__->_throw_error("enum called with an array reference and additional arguments. Did you mean to parenthesize the enum call's parameters?"); + @values = @$type_name; $type_name = undef; } - ( scalar @values >= 2 ) - || __PACKAGE__->_throw_error( - "You must have at least two values to enumerate through"); - my %valid = map { $_ => 1 } @values; + if ( @values == 1 && ref $values[0] eq 'ARRAY' ) { + @values = @{ $values[0] }; + } register_type_constraint( create_enum_type_constraint( @@ -442,6 +468,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,20 +592,54 @@ sub _install_type_coercions ($$) { use re "eval"; my $valid_chars = qr{[\w:\.]}; - my $type_atom = qr{ $valid_chars+ }; - - 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 $op_union = qr{ \s* \| \s* }x; - my $union = qr{ $type (?: $op_union $type )+ }x; + my $type_atom = qr{ (?>$valid_chars+) }x; + my $ws = qr{ (?>\s*) }x; + my $op_union = qr{ $ws \| $ws }x; + + my ($type, $type_capture_parts, $type_with_parameter, $union, $any); + if (Class::MOP::IS_RUNNING_ON_5_10) { + my $type_pattern + = q{ (?&type_atom) (?: \[ (?&ws) (?&any) (?&ws) \] )? }; + my $type_capture_parts_pattern + = q{ ((?&type_atom)) (?: \[ (?&ws) ((?&any)) (?&ws) \] )? }; + my $type_with_parameter_pattern + = q{ (?&type_atom) \[ (?&ws) (?&any) (?&ws) \] }; + my $union_pattern + = q{ (?&type) (?> (?: (?&op_union) (?&type) )+ ) }; + my $any_pattern + = q{ (?&type) | (?&union) }; + + my $defines = qr{(?(DEFINE) + (? $valid_chars) + (? $type_atom) + (? $ws) + (? $op_union) + (? $type_pattern) + (? $type_capture_parts_pattern) + (? $type_with_parameter_pattern) + (? $union_pattern) + (? $any_pattern) + )}x; + + $type = qr{ $type_pattern $defines }x; + $type_capture_parts = qr{ $type_capture_parts_pattern $defines }x; + $type_with_parameter = qr{ $type_with_parameter_pattern $defines }x; + $union = qr{ $union_pattern $defines }x; + $any = qr{ $any_pattern $defines }x; + } + else { + $type + = qr{ $type_atom (?: \[ $ws (??{$any}) $ws \] )? }x; + $type_capture_parts + = qr{ ($type_atom) (?: \[ $ws ((??{$any})) $ws \] )? }x; + $type_with_parameter + = qr{ $type_atom \[ $ws (??{$any}) $ws \] }x; + $union + = qr{ $type (?> (?: $op_union $type )+ ) }x; + $any + = qr{ $type | $union }x; + } - $any = qr{ $type | $union }x; sub _parse_parameterized_type_constraint { { no warnings 'void'; $any; } # force capture of interpolated lexical @@ -622,7 +715,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' => @@ -632,9 +725,6 @@ subtype 'Num' => as 'Str' => 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' } => @@ -657,6 +747,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; @@ -676,6 +767,24 @@ subtype 'RoleName' => as 'ClassName' => where { $REGISTRY->add_type_constraint( Moose::Meta::TypeConstraint::Parameterizable->new( + name => 'ScalarRef', + package_defined_in => __PACKAGE__, + parent => find_type_constraint('Ref'), + constraint => sub { ref($_) eq 'SCALAR' || ref($_) eq 'REF' }, + optimized => + \&Moose::Util::TypeConstraints::OptimizedConstraints::ScalarRef, + constraint_generator => sub { + my $type_parameter = shift; + my $check = $type_parameter->_compiled_type_constraint; + return sub { + return $check->(${ $_ }); + }; + } + ) +); + +$REGISTRY->add_type_constraint( + Moose::Meta::TypeConstraint::Parameterizable->new( name => 'ArrayRef', package_defined_in => __PACKAGE__, parent => find_type_constraint('Ref'), @@ -734,7 +843,7 @@ $REGISTRY->add_type_constraint( ); my @PARAMETERIZABLE_TYPES - = map { $REGISTRY->get_type_constraint($_) } qw[ArrayRef HashRef Maybe]; + = map { $REGISTRY->get_type_constraint($_) } qw[ScalarRef ArrayRef HashRef Maybe]; sub get_all_parameterizable_types {@PARAMETERIZABLE_TYPES} @@ -766,14 +875,12 @@ sub _throw_error { 1; +# ABSTRACT: Type constraint system for Moose + __END__ =pod -=head1 NAME - -Moose::Util::TypeConstraints - Type constraint system for Moose - =head1 SYNOPSIS use Moose::Util::TypeConstraints; @@ -847,27 +954,27 @@ that hierarchy represented visually. Undef Defined Value - Num - Int Str - ClassName - RoleName + Num + Int + ClassName + RoleName Ref - ScalarRef + ScalarRef[`a] ArrayRef[`a] HashRef[`a] 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: ArrayRef[Int] # an array of integers HashRef[CodeRef] # a hash of str to CODE ref mappings + ScalarRef[Int] # a reference to an integer Maybe[Str] # value may be a string, may be undefined If Moose finds a name in brackets that it does not recognize as an @@ -887,8 +994,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 @@ -946,7 +1052,7 @@ The following functions are used to create type constraints. They will also register the type constraints your create in a global registry that is used to look types up by name. -See the L for an example of how to use these. +See the L for an example of how to use these. =over 4 @@ -993,10 +1099,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 @@ -1004,30 +1110,30 @@ 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. -See the L for a simple example. +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 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', @@ -1064,11 +1170,11 @@ This can be used to define a "hand optimized" version of your type constraint which can be used to avoid traversing a subtype constraint hierarchy. -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 +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 +1188,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 @@ -1091,15 +1269,21 @@ the type-coercion code first, followed by the type constraint check. This feature should be used carefully as it is very powerful and could easily take off a limb if you are not careful. -See the L for an example of how to use these. +See the L for an example of how to use these. =over 4 -=item B<< coerce 'Name' => from 'OtherName' => via { ... } >> +=item B<< coerce 'Name' => from 'OtherName' => via { ... } >> This defines a coercion from one type to another. The C argument is the type you are coercing I. +To define multiple coercions, supply more sets of from/via pairs: + + coerce 'Name' => + from 'OtherName' => via { ... }, + from 'ThirdName' => via { ... }; + =item B This is just sugar for the type coercion construction syntax. @@ -1245,21 +1429,6 @@ 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. - -=head1 AUTHOR - -Stevan Little Estevan@iinteractive.comE - -=head1 COPYRIGHT AND LICENSE - -Copyright 2006-2009 by Infinity Interactive, Inc. - -L - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +See L for details on reporting bugs. =cut