X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil%2FTypeConstraints.pm;h=4a9e4aa59d8dcff50fd0432f4fffc84b424be1cf;hb=5a4c549307725560117d91a2d356645082371ee8;hp=0a0df2a9eaa2b4546e49272e153ee013b3aee8b3;hpb=e9ec68d692832824d0fc259df992ca1689538b53;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 0a0df2a..4a9e4aa 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -7,36 +7,51 @@ use warnings; use Carp 'confess'; use Scalar::Util 'blessed'; -our $VERSION = '0.03'; +our $VERSION = '0.05'; use Moose::Meta::TypeConstraint; use Moose::Meta::TypeCoercion; -sub import { - shift; - my $pkg = shift || caller(); - return if $pkg eq '-no-export'; - no strict 'refs'; - foreach my $export (qw(type subtype as where coerce from via find_type_constraint)) { - *{"${pkg}::${export}"} = \&{"${export}"}; - } +{ + 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'] + } + } + ); } { my %TYPES; - sub find_type_constraint { $TYPES{$_[0]}->[1] } - + sub find_type_constraint { + return $TYPES{$_[0]}->[1] + if exists $TYPES{$_[0]}; + return; + } + + sub _dump_type_constraints { + require Data::Dumper; + Data::Dumper::Dumper(\%TYPES); + } + sub _create_type_constraint { - my ($name, $parent, $check) = @_; + my ($name, $parent, $check, $message) = @_; my $pkg_defined_in = scalar(caller(1)); ($TYPES{$name}->[0] eq $pkg_defined_in) - || confess "The type constraint '$name' has already been created" + || confess "The type constraint '$name' has already been created " if defined $name && exists $TYPES{$name}; $parent = find_type_constraint($parent) if defined $parent; my $constraint = Moose::Meta::TypeConstraint->new( name => $name || '__ANON__', parent => $parent, - constraint => $check, + constraint => $check, + message => $message, ); $TYPES{$name} = [ $pkg_defined_in, $constraint ] if defined $name; return $constraint; @@ -70,8 +85,8 @@ sub type ($$) { _create_type_constraint($name, undef, $check); } -sub subtype ($$;$) { - unshift @_ => undef if scalar @_ == 2; +sub subtype ($$;$$) { + unshift @_ => undef if scalar @_ <= 2; _create_type_constraint(@_); } @@ -80,24 +95,37 @@ sub coerce ($@) { _install_type_coercions($type_name, \@coercion_map); } -sub as ($) { $_[0] } -sub from ($) { $_[0] } -sub where (&) { $_[0] } -sub via (&) { $_[0] } +sub as ($) { $_[0] } +sub from ($) { $_[0] } +sub where (&) { $_[0] } +sub via (&) { $_[0] } +sub message (&) { $_[0] } # define some basic types -type 'Any' => where { 1 }; +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' }; -type 'Value' => where { !ref($_) }; -type 'Ref' => where { ref($_) }; +subtype 'Value' => as 'Defined' => where { !ref($_) }; +subtype 'Ref' => as 'Defined' => where { ref($_) }; -subtype 'Int' => as 'Value' => where { Scalar::Util::looks_like_number($_) }; -subtype 'Str' => as 'Value' => where { !Scalar::Util::looks_like_number($_) }; +subtype 'Str' => as 'Value' => where { 1 }; + +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 'CollectionRef' => as 'Ref' => where { ref($_) eq 'ARRAY' || ref($_) eq 'HASH' }; + +subtype 'ArrayRef' => as 'CollectionRef' => where { ref($_) eq 'ARRAY' }; +subtype 'HashRef' => as 'CollectionRef' => where { ref($_) eq 'HASH' }; -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' }; @@ -105,6 +133,8 @@ subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' }; # blessed(qr/.../) returns true,.. how odd subtype 'Object' => as 'Ref' => where { blessed($_) && blessed($_) ne 'Regexp' }; +subtype 'Role' => as 'Object' => where { $_->can('does') }; + 1; __END__ @@ -127,7 +157,8 @@ Moose::Util::TypeConstraints - Type constraint system for Moose subtype NaturalLessThanTen => as Natural - => where { $_ < 10 }; + => where { $_ < 10 } + => message { "This number ($_) is not less than ten!" }; coerce Num => from Str @@ -154,16 +185,23 @@ 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 - Value - Int - Str - Ref - ScalarRef - ArrayRef - HashRef - CodeRef - RegexpRef - Object + Item + Bool + Undef + Defined + Value + Num + Int + Str + Ref + ScalarRef + CollectionRef + ArrayRef + HashRef + CodeRef + RegexpRef + Object + Role Suggestions for improvement are welcome. @@ -200,11 +238,11 @@ See the L for an example of how to use these. This creates a base type, which has no parent. -=item B +=item B This creates a named subtype. -=item B +=item B This creates an unnamed subtype and will return the type constraint meta-object, which will be an instance of @@ -218,6 +256,10 @@ This is just sugar for the type constraint construction syntax. This is just sugar for the type constraint construction syntax. +=item B + +This is just sugar for the type constraint construction syntax. + =back =head2 Type Coercion Constructors @@ -263,4 +305,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