From: Guillermo Roditi Date: Thu, 13 Mar 2008 23:05:59 +0000 (+0000) Subject: allow class_type to accept a custom message. sorry about the diffnoise, editor strips... X-Git-Tag: 0_55~283 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4ab662d626bb70974ff350b5940419d5f254c45f;p=gitmo%2FMoose.git allow class_type to accept a custom message. sorry about the diffnoise, editor strips trailing whitespace --- diff --git a/Changes b/Changes index 862ecbe..f6fc653 100644 --- a/Changes +++ b/Changes @@ -25,6 +25,9 @@ Revision history for Perl extension Moose - added tests for this * Moose::Util::TypeConstraints + - class_type now accepts an optional second argument for a + custom message. POD anotated accordingly (groditi) + - added tests for this - it is now possible to make anon-enums by passing 'enum' an ARRAY ref instead of the $name => @values. Everything else works as before. diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 903ec91..b33c0f6 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -24,12 +24,13 @@ sub register_type_constraint ($); sub find_or_create_type_constraint ($;$); sub create_type_constraint_union (@); sub create_parameterized_type_constraint ($); -sub create_class_type_constraint ($); +sub create_class_type_constraint ($;$); +#sub create_class_type_constraint ($); # dah sugah! sub type ($$;$$); sub subtype ($$;$$$); -sub class_type ($); +sub class_type ($;$); sub coerce ($@); sub as ($); sub from ($); @@ -153,14 +154,21 @@ sub create_parameterized_type_constraint ($) { ); } -sub create_class_type_constraint ($) { +#should we also support optimized checks? +sub create_class_type_constraint ($;$) { my $class = shift; - # too early for this check #find_type_constraint("ClassName")->check($class) # || confess "Can't create a class type constraint because '$class' is not a class name"; + my $message; + if( $_[0] ){ + $message = $_[0]->{message} if exists $_[0]->{message}; + } - Moose::Meta::TypeConstraint::Class->new( name => $class ); + Moose::Meta::TypeConstraint::Class->new( + name => $class, + ($message ? (message => $message) : ()) + ); } sub find_or_create_type_constraint ($;$) { @@ -179,10 +187,10 @@ sub find_or_create_type_constraint ($;$) { } else { # NOTE: - # if there is no $options_for_anon_type - # specified, then we assume they don't + # if there is no $options_for_anon_type + # specified, then we assume they don't # want to create one, and return nothing. - return unless defined $options_for_anon_type; + return unless defined $options_for_anon_type; # NOTE: # otherwise assume that we should create @@ -234,8 +242,13 @@ sub subtype ($$;$$$) { goto &_create_type_constraint; } -sub class_type ($) { - register_type_constraint( create_class_type_constraint(shift) ); +sub class_type ($;$) { + register_type_constraint( + create_class_type_constraint( + $_[0], + ( defined($_[1]) ? $_[1] : () ), + ) + ); } sub coerce ($@) { @@ -253,8 +266,8 @@ sub optimize_as (&) { +{ optimized => $_[0] } } sub enum ($;@) { my ($type_name, @values) = @_; - # NOTE: - # if only an array-ref is passed then + # NOTE: + # if only an array-ref is passed then # you get an anon-enum # - SL if (ref $type_name eq 'ARRAY' && !@values) { @@ -299,7 +312,7 @@ sub _create_type_constraint ($$$;$$) { } $parent = find_or_create_type_constraint($parent) if defined $parent; - + my $constraint = Moose::Meta::TypeConstraint->new( name => $name || '__ANON__', package_defined_in => $pkg_defined_in, @@ -309,21 +322,21 @@ sub _create_type_constraint ($$$;$$) { ($message ? (message => $message) : ()), ($optimized ? (optimized => $optimized) : ()), ); - + # NOTE: - # if we have a type constraint union, and no + # if we have a type constraint union, and no # type check, this means we are just aliasing - # the union constraint, which means we need to + # the union constraint, which means we need to # handle this differently. # - SL - if (not(defined $check) - && $parent->isa('Moose::Meta::TypeConstraint::Union') - && $parent->has_coercion + if (not(defined $check) + && $parent->isa('Moose::Meta::TypeConstraint::Union') + && $parent->has_coercion ){ $constraint->coercion(Moose::Meta::TypeCoercion::Union->new( type_constraint => $parent )); - } + } $REGISTRY->add_type_constraint($constraint) if defined $name; @@ -529,7 +542,7 @@ $REGISTRY->add_type_constraint( constraint => sub { ref($_) eq 'HASH' }, optimized => \&Moose::Util::TypeConstraints::OptimizedConstraints::HashRef, constraint_generator => sub { - my $type_parameter = shift; + my $type_parameter = shift; return sub { foreach my $x (values %$_) { ($type_parameter->check($x)) || return @@ -546,7 +559,7 @@ $REGISTRY->add_type_constraint( parent => find_type_constraint('Item'), constraint => sub { 1 }, constraint_generator => sub { - my $type_parameter = shift; + my $type_parameter = shift; return sub { return 1 if not(defined($_)) || $type_parameter->check($_); return; @@ -555,17 +568,17 @@ $REGISTRY->add_type_constraint( ) ); -my @PARAMETERIZABLE_TYPES = map { - $REGISTRY->get_type_constraint($_) +my @PARAMETERIZABLE_TYPES = map { + $REGISTRY->get_type_constraint($_) } qw[ArrayRef HashRef Maybe]; sub get_all_parameterizable_types { @PARAMETERIZABLE_TYPES } -sub add_parameterizable_type { +sub add_parameterizable_type { my $type = shift; (blessed $type && $type->isa('Moose::Meta::TypeConstraint::Parameterizable')) || confess "Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type"; push @PARAMETERIZABLE_TYPES => $type; -} +} ## -------------------------------------------------------- # end of built-in types ... @@ -674,20 +687,20 @@ could probably use some work, but it works for me at the moment. Suggestions for improvement are welcome. -B Any type followed by a type parameter C<[`a]> can be +B Any type followed by a type parameter C<[`a]> can be parameterized, this means you can say: ArrayRef[Int] # an array of intergers HashRef[CodeRef] # a hash of str to CODE ref mappings Maybe[Str] # value may be a string, may be undefined -B The C type constraint for the most part works -correctly now, but edge cases may still exist, please use it +B The C type constraint for the most part works +correctly now, but edge cases may still exist, please use it sparringly. 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. I know this is not ideal for all, +existence check. This means that your class B be loaded for +this type constraint to pass. I know this is not ideal for all, but it is a saner restriction than most others. =head2 Use with Other Constraint Modules @@ -742,9 +755,9 @@ Given a C<$type_name> in the form of: BaseType[ContainerType] this will extract the base type and container type and build an instance of -L for it. +L for it. -=item B +=item B Given a class name it will create a new L object for that class name. @@ -826,7 +839,7 @@ This creates an unnamed subtype and will return the type constraint meta-object, which will be an instance of L. -=item B +=item B Creates a type constraint with the name C<$class> and the metaclass L. @@ -843,13 +856,13 @@ a convient constraint builder. =item B -If passed an ARRAY reference instead of the C<$name>, C<@values> pair, +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: has 'sort_order' => ( is => 'ro', - isa => enum([qw[ ascending descending ]]), + isa => enum([qw[ ascending descending ]]), ); =item B diff --git a/t/040_type_constraints/020_class_type_constraint.t b/t/040_type_constraints/020_class_type_constraint.t index 628dd19..7fe4b7b 100644 --- a/t/040_type_constraints/020_class_type_constraint.t +++ b/t/040_type_constraints/020_class_type_constraint.t @@ -3,10 +3,11 @@ use strict; use warnings; -use Test::More tests => 7; +use Test::More tests => 12; +use Test::Exception; BEGIN { - use_ok('Moose::Util::TypeConstraints'); + use_ok('Moose::Util::TypeConstraints'); } { @@ -20,8 +21,13 @@ BEGIN { use Moose; extends qw(Bar Gorch); + } +lives_ok { class_type 'Beep' } 'class_type keywork works'; +lives_ok { class_type('Boop', message { "${_} is not a Boop" }) } + 'class_type keywork works with message'; + my $type = find_type_constraint("Foo"); ok( $type->is_subtype_of("Gorch"), "subtype of gorch" ); @@ -34,3 +40,8 @@ ok( find_type_constraint("Bar")->check(Foo->new), "Foo passes Bar" ); ok( find_type_constraint("Bar")->check(Bar->new), "Bar passes Bar" ); ok( !find_type_constraint("Gorch")->check(Bar->new), "but Bar doesn't pass Gorch"); +ok( find_type_constraint("Beep")->check( bless {} => 'Beep' ), "Beep passes Beep" ); +my $boop = find_type_constraint("Boop"); +ok( $boop->has_message, 'Boop has a message'); +my $error = $boop->get_message(Foo->new); +like( $error, qr/is not a Boop/, 'boop gives correct error message');