X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil%2FTypeConstraints.pm;h=e5b9e9904d063bd2237f8689e331a23c01142a62;hb=9e93dd19f8c035b497ddc9ed8a8628e66042015e;hp=d987f0e76e7e903d684ddff0317883c211c3c30f;hpb=f65cb5347d0bfa2de4cafa99ba71bad39a1d1691;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index d987f0e..e5b9e99 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -7,29 +7,26 @@ use warnings; use Carp 'confess'; use Scalar::Util 'blessed'; -our $VERSION = '0.05'; +our $VERSION = '0.07'; use Moose::Meta::TypeConstraint; use Moose::Meta::TypeCoercion; -{ - require Sub::Exporter; - - my @exports = qw[type subtype as where message coerce from via find_type_constraint]; - - Sub::Exporter->import( - -setup => { - exports => \@exports, - groups => { - default => [':all'] - } - } - ); -} +use Sub::Exporter -setup => { + exports => [qw/ + type subtype as where message + coerce from via + enum + find_type_constraint + /], + groups => { + default => [':all'] + } +}; { my %TYPES; - sub find_type_constraint { + sub find_type_constraint ($) { return $TYPES{$_[0]}->[1] if exists $TYPES{$_[0]}; return; @@ -40,7 +37,7 @@ use Moose::Meta::TypeCoercion; Data::Dumper::Dumper(\%TYPES); } - sub _create_type_constraint { + sub _create_type_constraint ($$$;$) { my ($name, $parent, $check, $message) = @_; my $pkg_defined_in = scalar(caller(1)); ($TYPES{$name}->[0] eq $pkg_defined_in) @@ -57,7 +54,7 @@ use Moose::Meta::TypeCoercion; return $constraint; } - sub _install_type_coercions { + sub _install_type_coercions ($$) { my ($type_name, $coercion_map) = @_; my $type = find_type_constraint($type_name); (!$type->has_coercion) @@ -69,6 +66,15 @@ use Moose::Meta::TypeCoercion; $type->coercion($type_coercion); } + sub create_type_constraint_union (@) { + my (@type_constraint_names) = @_; + return Moose::Meta::TypeConstraint->union( + map { + find_type_constraint($_) + } @type_constraint_names + ); + } + sub export_type_contstraints_as_functions { my $pkg = caller(); no strict 'refs'; @@ -87,7 +93,7 @@ sub type ($$) { sub subtype ($$;$$) { unshift @_ => undef if scalar @_ <= 2; - _create_type_constraint(@_); + goto &_create_type_constraint; } sub coerce ($@) { @@ -101,6 +107,18 @@ sub where (&) { $_[0] } sub via (&) { $_[0] } sub message (&) { $_[0] } +sub enum ($;@) { + my ($type_name, @values) = @_; + (scalar @values >= 2) + || confess "You must have at least two values to enumerate through"; + my $regexp = join '|' => @values; + _create_type_constraint( + $type_name, + 'Str', + sub { qr/^$regexp$/i } + ); +} + # define some basic types type 'Any' => where { 1 }; # meta-type including all @@ -109,21 +127,19 @@ type 'Item' => where { 1 }; # base-type subtype 'Undef' => as 'Item' => where { !defined($_) }; subtype 'Defined' => as 'Item' => where { defined($_) }; -subtype 'Value' => as 'Item' => where { !ref($_) }; -subtype 'Ref' => as 'Item' => where { ref($_) }; - -subtype 'Bool' => as 'Item' => where { "$_" eq '1' || "$_" eq '0' }; - -subtype 'Int' => as 'Value' => where { Scalar::Util::looks_like_number($_) }; -subtype 'Str' => as 'Value' => where { !Scalar::Util::looks_like_number($_) }; +subtype 'Bool' => as 'Item' => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' }; -subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' }; +subtype 'Value' => as 'Defined' => where { !ref($_) }; +subtype 'Ref' => as 'Defined' => where { ref($_) }; -subtype 'CollectionRef' => as 'Ref' => where { ref($_) eq 'ARRAY' || ref($_) eq 'HASH' }; +subtype 'Str' => as 'Value' => where { 1 }; -subtype 'ArrayRef' => as 'CollectionRef' => where { ref($_) eq 'ARRAY' }; -subtype 'HashRef' => as 'CollectionRef' => where { ref($_) eq 'HASH' }; +subtype 'Num' => as 'Value' => where { Scalar::Util::looks_like_number($_) }; +subtype 'Int' => as 'Num' => where { "$_" =~ /^-?[0-9]+$/ }; +subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' }; +subtype 'ArrayRef' => as 'Ref' => where { ref($_) eq 'ARRAY' }; +subtype 'HashRef' => as 'Ref' => where { ref($_) eq 'HASH' }; subtype 'CodeRef' => as 'Ref' => where { ref($_) eq 'CODE' }; subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' }; @@ -147,20 +163,22 @@ Moose::Util::TypeConstraints - Type constraint system for Moose use Moose::Util::TypeConstraints; - type Num => where { Scalar::Util::looks_like_number($_) }; + type 'Num' => where { Scalar::Util::looks_like_number($_) }; - subtype Natural - => as Num + subtype 'Natural' + => as 'Num' => where { $_ > 0 }; - subtype NaturalLessThanTen - => as Natural + subtype 'NaturalLessThanTen' + => as 'Natural' => where { $_ < 10 } => message { "This number ($_) is not less than ten!" }; - coerce Num - => from Str + coerce 'Num' + => from 'Str' => via { 0+$_ }; + + enum 'RGBColors' => qw(red green blue); =head1 DESCRIPTION @@ -177,31 +195,57 @@ inference is performed, expression are not typed, etc. etc. etc. This is simply a means of creating small constraint functions which can be used to simplify your own type-checking code. +=head2 Slightly Less Important Caveat + +It is almost always a good idea to quote your type and subtype names. +This is to prevent perl from trying to create the call as an indirect +object call. This issue only seems to come up when you have a subtype +the same name as a valid class, but when the issue does arise it tends +to be quite annoying to debug. + +So for instance, this: + + subtype DateTime => as Object => where { $_->isa('DateTime') }; + +will I, while this: + + use DateTime; + subtype DateTime => as Object => where { $_->isa('DateTime') }; + +will fail silently and cause many headaches. The simple way to solve +this, as well as future proof your subtypes from classes which have +yet to have been created yet, is to simply do this: + + use DateTime; + subtype 'DateTime' => as Object => where { $_->isa('DateTime') }; + =head2 Default Type Constraints This module also provides a simple hierarchy for Perl 5 types, this could probably use some work, but it works for me at the moment. Any - Item + Bool Undef Defined - Bool - Value - Int - Str - Ref - ScalarRef - CollectionRef + Value + Num + Int + Str + Ref + ScalarRef ArrayRef HashRef - CodeRef - RegexpRef - Object - Role + CodeRef + RegexpRef + Object + Role Suggestions for improvement are welcome. + +B The C type constraint does not work correctly +in every occasion, please use it sparringly. =head1 FUNCTIONS @@ -214,6 +258,11 @@ Suggestions for improvement are welcome. This function can be used to locate a specific type constraint meta-object. What you do with it from there is up to you :) +=item B + +Given a list of C<@type_constraint_names>, this will return a +B instance. + =item B This will export all the current type constraints as functions @@ -246,6 +295,16 @@ This creates an unnamed subtype and will return the type constraint meta-object, which will be an instance of L. +=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>. See the L +for a simple example. + +B This is not a true proper enum type, it is simple +a convient constraint builder. + =item B This is just sugar for the type constraint construction syntax. @@ -303,4 +362,4 @@ L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -=cut \ No newline at end of file +=cut