X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil%2FTypeConstraints.pm;h=056d052f9ac525a378a4d871a6123efe9f0d39b2;hb=0a5bd159bfe05bc23ca4ce974e83dbaf85a6be71;hp=a4a02f4b12f1f66941ad365461943e3447f2f7a8;hpb=6b8bd8d3bc7470493af007431efe7b70e1eb7970;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index a4a02f4..056d052 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -5,143 +5,155 @@ use strict; use warnings; use Carp 'confess'; -use Sub::Name 'subname'; use Scalar::Util 'blessed'; -our $VERSION = '0.02'; +our $VERSION = '0.08'; -sub import { - shift; - my $pkg = shift || caller(); - return if $pkg eq ':no_export'; - no strict 'refs'; - foreach my $export (qw(type subtype as where to coerce)) { - *{"${pkg}::${export}"} = \&{"${export}"}; - } -} +use Moose::Meta::TypeConstraint; +use Moose::Meta::TypeCoercion; + +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 { - my $type_name = shift; - $TYPES{$type_name}; + 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, $message) = @_; + my $pkg_defined_in = scalar(caller(1)); + ($TYPES{$name}->[0] eq $pkg_defined_in) + || 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, + message => $message, + ); + $TYPES{$name} = [ $pkg_defined_in, $constraint ] if defined $name; + return $constraint; } - sub register_type_constraint { - my ($type_name, $type_constraint) = @_; - $TYPES{$type_name} = $type_constraint; + sub _install_type_coercions ($$) { + my ($type_name, $coercion_map) = @_; + my $type = find_type_constraint($type_name); + (!$type->has_coercion) + || confess "The type coercion for '$type_name' has already been registered"; + my $type_coercion = Moose::Meta::TypeCoercion->new( + type_coercion_map => $coercion_map, + type_constraint => $type + ); + $type->coercion($type_coercion); } - sub dump_type_constraints { - require Data::Dumper; - $Data::Dumper::Deparse = 1; - Data::Dumper::Dumper(\%TYPES); + 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'; foreach my $constraint (keys %TYPES) { - *{"${pkg}::${constraint}"} = $TYPES{$constraint}; + *{"${pkg}::${constraint}"} = find_type_constraint($constraint)->_compiled_type_constraint; } - } -} - -{ - my %COERCIONS; - sub find_type_coercion { - my $type_name = shift; - $COERCIONS{$type_name}; - } - - sub register_type_coercion { - my ($type_name, $type_coercion) = @_; - $COERCIONS{$type_name} = $type_coercion; - } + } } +# type constructors sub type ($$) { my ($name, $check) = @_; - my $full_name = caller() . "::${name}"; - register_type_constraint($name => subname $full_name => sub { - local $_ = $_[0]; - return undef unless $check->($_[0]); - $_[0]; - }); + _create_type_constraint($name, undef, $check); } -sub subtype ($$;$) { - my ($name, $parent, $check) = @_; - if (defined $check) { - my $full_name = caller() . "::${name}"; - $parent = find_type_constraint($parent) - unless $parent && ref($parent) eq 'CODE'; - register_type_constraint($name => subname $full_name => sub { - local $_ = $_[0]; - return undef unless defined $parent->($_[0]) && $check->($_[0]); - $_[0]; - }); - } - else { - ($parent, $check) = ($name, $parent); - $parent = find_type_constraint($parent) - unless $parent && ref($parent) eq 'CODE'; - return subname '__anon_subtype__' => sub { - local $_ = $_[0]; - return undef unless defined $parent->($_[0]) && $check->($_[0]); - $_[0]; - }; - } +sub subtype ($$;$$) { + unshift @_ => undef if scalar @_ <= 2; + goto &_create_type_constraint; } sub coerce ($@) { - my ($type_name, @coercion_map) = @_; - #use Data::Dumper; - #warn Dumper \@coercion_map; - my @coercions; - while (@coercion_map) { - my ($constraint_name, $action) = splice(@coercion_map, 0, 2); - my $constraint = find_type_constraint($constraint_name); - (defined $constraint) - || confess "Could not find the type constraint ($constraint_name)"; - push @coercions => [ $constraint, $action ]; - } - register_type_coercion($type_name, sub { - my $thing = shift; - foreach my $coercion (@coercions) { - my ($constraint, $converter) = @$coercion; - if (defined $constraint->($thing)) { - return $converter->($thing); - } - } - return $thing; - }); + my ($type_name, @coercion_map) = @_; + _install_type_coercions($type_name, \@coercion_map); } -sub as ($) { $_[0] } -sub where (&) { $_[0] } -sub to (&) { $_[0] } +sub as ($) { $_[0] } +sub from ($) { $_[0] } +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 }; +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 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' }; +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' }; +subtype 'GlobRef' => as 'Ref' => where { ref($_) eq 'GLOB' }; + +# NOTE: +# scalar filehandles are GLOB refs, +# but a GLOB ref is not always a filehandle +subtype 'FileHandle' => as 'GlobRef' => where { Scalar::Util::openhandle($_) }; # NOTE: # blessed(qr/.../) returns true,.. how odd -subtype Object => as Ref => where { blessed($_) && blessed($_) ne 'Regexp' }; +subtype 'Object' => as 'Ref' => where { blessed($_) && blessed($_) ne 'Regexp' }; + +subtype 'Role' => as 'Object' => where { $_->can('does') }; 1; @@ -157,19 +169,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 - => where { $_ < 10 }; + subtype 'NaturalLessThanTen' + => as 'Natural' + => where { $_ < 10 } + => message { "This number ($_) is not less than ten!" }; - coerce Num - => as Str - => to { 0+$_ }; + coerce 'Num' + => from 'Str' + => via { 0+$_ }; + + enum 'RGBColors' => qw(red green blue); =head1 DESCRIPTION @@ -177,24 +192,68 @@ This module provides Moose with the ability to create type contraints to be are used in both attribute definitions and for method argument validation. -This is B a type system for Perl 5. +=head2 Important Caveat + +This is B a type system for Perl 5. These are type constraints, +and they are not used by Moose unless you tell it to. No type +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 execute 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 - Value - Int - Str - Ref - ScalarRef - ArrayRef - HashRef - CodeRef - RegexpRef - Object - -Suggestions for improvement are welcome. + Item + Bool + Undef + Defined + Value + Num + Int + Str + Ref + ScalarRef + ArrayRef + HashRef + CodeRef + RegexpRef + GlobRef + FileHandle + 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 @@ -204,61 +263,91 @@ Suggestions for improvement are welcome. =item B -=item B +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 +=item B -=item B +Given a list of C<@type_constraint_names>, this will return a +B instance. =item B -=item B +This will export all the current type constraints as functions +into the caller's namespace. Right now, this is mostly used for +testing, but it might prove useful to others. =back =head2 Type Constraint Constructors +The following functions are used to create type constraints. +They will then register the type constraints in a global store +where Moose can get to them if it needs to. + +See the L for an example of how to use these. + =over 4 -=item B +=item B -=item B +This creates a base type, which has no parent. -=item B +=item B -=item B +This creates a named subtype. -=item B +=item B -=item B +This creates an unnamed subtype and will return the type +constraint meta-object, which will be an instance of +L. -=back +=item B -=head2 Built-in Type Constraints +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. -=over 4 +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. + +=item B + +This is just sugar for the type constraint construction syntax. + +=item B -=item B +This is just sugar for the type constraint construction syntax. -=item B +=back -=item B +=head2 Type Coercion Constructors -=item B +Type constraints can also contain type coercions as well. In most +cases Moose will run 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. -=item B +See the L for an example of how to use these. -=item B +=over 4 -=item B +=item B -=item B +=item B -=item B +This is just sugar for the type coercion construction syntax. -=item B +=item B -=item B +This is just sugar for the type coercion construction syntax. =back @@ -281,4 +370,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