X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMouse%2FUtil%2FTypeConstraints.pm;h=4f77130b4b090b189d90d4a010855c898cc5bad2;hb=29607c0291634fac077d6e1c75e1491ba455c010;hp=dc569a9b7321469a9329b3c8ffe625270b803ed5;hpb=ccf442276cab228f5346a4ba2aa90268941a0ecf;p=gitmo%2FMouse.git diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm index dc569a9..4f77130 100644 --- a/lib/Mouse/Util/TypeConstraints.pm +++ b/lib/Mouse/Util/TypeConstraints.pm @@ -5,6 +5,7 @@ use base 'Exporter'; use Carp (); use Scalar::Util qw/blessed looks_like_number openhandle/; +use Mouse::Meta::TypeConstraint; our @EXPORT = qw( as where message from via type subtype coerce class_type role_type enum @@ -63,8 +64,8 @@ BEGIN { Object => sub { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }, ); - foreach my $code (values %TYPE) { - bless $code, 'Mouse::Meta::TypeConstraint'; + while (my ($name, $code) = each %TYPE) { + $TYPE{$name} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $name ); } sub optimized_constraints { \%TYPE } @@ -89,7 +90,17 @@ sub type { }; $TYPE_SOURCE{$name} = $pkg; - $TYPE{$name} = sub { local $_ = $_[0]; $constraint->($_[0]) }; + $TYPE{$name} = Mouse::Meta::TypeConstraint->new( + name => $name, + _compiled_type_constraint => sub { + local $_ = $_[0]; + if (ref $constraint eq 'CODE') { + $constraint->($_[0]) + } else { + $constraint->check($_[0]) + } + } + ); } sub subtype { @@ -98,20 +109,25 @@ sub subtype { if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) { Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg"; }; - my $constraint = $conf{where}; - my $as_constraint = find_or_create_isa_type_constraint($conf{as} || 'Any'); + my $constraint = delete $conf{where}; + my $as_constraint = find_or_create_isa_type_constraint(delete $conf{as} || 'Any'); $TYPE_SOURCE{$name} = $pkg; - $TYPE{$name} = $constraint ? - sub { - local $_ = $_[0]; - $as_constraint->($_[0]) && $constraint->($_[0]) - } : - sub { - local $_ = $_[0]; - $as_constraint->($_[0]); - } - ; + $TYPE{$name} = Mouse::Meta::TypeConstraint->new( + name => $name, + _compiled_type_constraint => ( + $constraint ? + sub { + local $_ = $_[0]; + $as_constraint->check($_[0]) && $constraint->($_[0]) + } : + sub { + local $_ = $_[0]; + $as_constraint->check($_[0]); + } + ), + %conf + ); return $name; } @@ -133,13 +149,13 @@ sub coerce { if (! $TYPE{$type}) { # looks parameterized if ($type =~ /^[^\[]+\[.+\]$/) { - _build_type_constraint($type); + $TYPE{$type} = _build_type_constraint($type); } else { Carp::croak "Could not find the type constraint ($type) to coerce from" } } - push @{ $COERCE_KEYS{$name} }, $type; + unshift @{ $COERCE_KEYS{$name} }, $type; $COERCE{$name}->{$type} = $code; } } @@ -168,18 +184,20 @@ sub role_type { ); } +# this is an original method for Mouse sub typecast_constraints { - my($class, $pkg, $type_constraint, $types, $value) = @_; + my($class, $pkg, $types, $value) = @_; + Carp::croak("wrong arguments count") unless @_==4; local $_; - for my $type (ref($types) eq 'ARRAY' ? @{ $types } : ( $types )) { + for my $type ( split /\|/, $types ) { next unless $COERCE{$type}; for my $coerce_type (@{ $COERCE_KEYS{$type}}) { $_ = $value; - next unless $TYPE{$coerce_type}->($value); + next unless $TYPE{$coerce_type}->check($value); $_ = $value; $_ = $COERCE{$type}->{$coerce_type}->($value); - return $_ if $type_constraint->($_); + return $_ if $types->check($_); } } return $value; @@ -210,6 +228,7 @@ sub _build_type_constraint { my $spec = shift; my $code; + $spec =~ s/\s+//g; if ($spec =~ /^([^\[]+)\[(.+)\]$/) { # parameterized my $constraint = $1; @@ -225,9 +244,9 @@ sub _build_type_constraint { my $code_str = "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" . "sub {\n" . - " if (\$parent->(\$_[0])) {\n" . + " if (\$parent->check(\$_[0])) {\n" . " foreach my \$e (\@{\$_[0]}) {\n" . - " return () unless \$child->(\$e);\n" . + " return () unless \$child->check(\$e);\n" . " }\n" . " return 1;\n" . " }\n" . @@ -239,9 +258,9 @@ sub _build_type_constraint { my $code_str = "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" . "sub {\n" . - " if (\$parent->(\$_[0])) {\n" . + " if (\$parent->check(\$_[0])) {\n" . " foreach my \$e (values \%{\$_[0]}) {\n" . - " return () unless \$child->(\$e);\n" . + " return () unless \$child->check(\$e);\n" . " }\n" . " return 1;\n" . " }\n" . @@ -253,28 +272,32 @@ sub _build_type_constraint { my $code_str = "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" . "sub {\n" . - " return \$child->(\$_[0]) || \$parent->(\$_[0]);\n" . + " return \$child->check(\$_[0]) || \$parent->check(\$_[0]);\n" . "};\n" ; $code = eval $code_str or Carp::confess($@); } else { - Carp::confess("Support for parameterized types other than ArrayRef or HashRef is not implemented yet"); + Carp::confess("Support for parameterized types other than Maybe, ArrayRef or HashRef is not implemented yet"); } - $TYPE{$spec} = $code; + $TYPE{$spec} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec ); } else { $code = $TYPE{ $spec }; if (! $code) { + # is $spec a known role? If so, constrain with 'does' instead of 'isa' + require Mouse::Meta::Role; + my $check = Mouse::Meta::Role->_metaclass_cache($spec)? + 'does' : 'isa'; my $code_str = "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" . "sub {\n" . - " Scalar::Util::blessed(\$_[0]) && \$_[0]->isa('$spec');\n" . + " Scalar::Util::blessed(\$_[0]) && \$_[0]->$check('$spec');\n" . "}" ; $code = eval $code_str or Carp::confess($@); - $TYPE{$spec} = bless $code, 'Mouse::Meta::TypeConstraint'; + $TYPE{$spec} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec ); } } - return bless $code, 'Mouse::Meta::TypeConstraint'; + return Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec ); } sub find_type_constraint { @@ -288,40 +311,197 @@ sub find_or_create_isa_type_constraint { my $code; $type_constraint =~ s/\s+//g; - my @type_constraints = split /\|/, $type_constraint; - if (@type_constraints == 1) { - $code = $TYPE{$type_constraints[0]} || - _build_type_constraint($type_constraints[0]); - } else { - my @code_list = map { - $TYPE{$_} || _build_type_constraint($_) - } @type_constraints; - $code = bless sub { - my $i = 0; - for my $code (@code_list) { - return 1 if $code->($_[0]); - } - return 0; - }, 'Mouse::Meta::TypeConstraint'; + + $code = $TYPE{$type_constraint}; + if (! $code) { + my @type_constraints = split /\|/, $type_constraint; + if (@type_constraints == 1) { + $code = $TYPE{$type_constraints[0]} || + _build_type_constraint($type_constraints[0]); + } else { + my @code_list = map { + $TYPE{$_} || _build_type_constraint($_) + } @type_constraints; + $code = Mouse::Meta::TypeConstraint->new( + _compiled_type_constraint => sub { + my $i = 0; + for my $code (@code_list) { + return 1 if $code->check($_[0]); + } + return 0; + }, + name => $type_constraint, + ); + } } return $code; } -package # Hide from pause - Mouse::Meta::TypeConstraint; - -sub check { - $_[0]->($_[1]) -} - - 1; __END__ =head1 NAME -Mouse::Util::TypeConstraints - simple type constraints +Mouse::Util::TypeConstraints - Type constraint system for Mouse + +=head2 SYNOPSIS + + use Mouse::Util::TypeConstraints; + + subtype 'Natural' + => as 'Int' + => where { $_ > 0 }; + + subtype 'NaturalLessThanTen' + => as 'Natural' + => where { $_ < 10 } + => message { "This number ($_) is not less than ten!" }; + + coerce 'Num' + => from 'Str' + => via { 0+$_ }; + + enum 'RGBColors' => qw(red green blue); + + no Mouse::Util::TypeConstraints; + +=head1 DESCRIPTION + +This module provides Mouse with the ability to create custom type +constraints to be used in attribute definition. + +=head2 Important Caveat + +This is B a type system for Perl 5. These are type constraints, +and they are not used by Mouse unless you tell it to. No type +inference is performed, expressions are not typed, etc. etc. etc. + +A type constraint is at heart a small "check if a value is valid" +function. A constraint can be associated with an attribute. This +simplifies parameter validation, and makes your code clearer to read, +because you can refer to constraints by name. + +=head2 Slightly Less Important Caveat + +It is B a good idea to quote your type names. + +This prevents Perl from trying to execute the call as an indirect +object call. This can be an issue when you have a subtype with the +same name as a valid class. + +For instance: + + 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, is to quote the type name: + + use DateTime; + subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') }; + +=head2 Default Type Constraints + +This module also provides a simple hierarchy for Perl 5 types, here is +that hierarchy represented visually. + + Any + Item + Bool + Maybe[`a] + Undef + Defined + Value + Num + Int + Str + ClassName + RoleName + Ref + ScalarRef + ArrayRef[`a] + HashRef[`a] + CodeRef + RegexpRef + GlobRef + 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 + Maybe[Str] # value may be a string, may be undefined + +If Mouse finds a name in brackets that it does not recognize as an +existing type, it assumes that this is a class name, for example +C. + +B Unless you parameterize a type, then it is invalid to include +the square brackets. I.e. C will be treated as a new type +name, I as a parameterization of C. + +B The C type constraint for the most part works +correctly now, but edge cases may still exist, please use it +sparingly. + +B The C type constraint does a complex package +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. + +=head2 Type Constraint Naming + +Type name declared via this module can only contain alphanumeric +characters, colons (:), and periods (.). + +Since the types created by this module are global, it is suggested +that you namespace your types just as you would namespace your +modules. So instead of creating a I type for your +B module, you would call the type +I instead. + +=head2 Use with Other Constraint Modules + +This module can play nicely with other constraint modules with some +slight tweaking. The C clause in types is expected to be a +C reference which checks it's first argument and returns a +boolean. Since most constraint modules work in a similar way, it +should be simple to adapt them to work with Mouse. + +For instance, this is how you could use it with +L to declare a completely new type. + + type 'HashOfArrayOfObjects', + { + where => IsHashRef( + -keys => HasLength, + -values => IsArrayRef(IsObject) + ) + }; + +Here is an example of using L and it's non-test +related C function. + + type 'ArrayOfHashOfBarsAndRandomNumbers' + => where { + eq_deeply($_, + array_each(subhashof({ + bar => isa('Bar'), + random_number => ignore() + }))) + }; =head1 METHODS @@ -345,6 +525,10 @@ Returns the simple type constraints that Mouse understands. =back +=head1 THANKS + +Much of this documentation was taken from L + =cut