use warnings;
use metaclass;
-our $VERSION = '0.04';
+use Moose::Meta::TypeCoercion::Union;
+
+our $VERSION = '0.87';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
+use base 'Moose::Meta::TypeConstraint';
+
__PACKAGE__->meta->add_attribute('type_constraints' => (
accessor => 'type_constraints',
default => sub { [] }
));
-sub new {
- my $class = shift;
- my $self = $class->meta->new_object(@_);
+sub new {
+ my ($class, %options) = @_;
+
+ my $name = join '|' => sort { $a cmp $b }
+ map { $_->name } @{ $options{type_constraints} };
+
+ my $self = $class->SUPER::new(
+ name => $name,
+ %options,
+ );
+
+ $self->_set_constraint(sub { $self->check($_[0]) });
+ $self->coercion(Moose::Meta::TypeCoercion::Union->new(
+ type_constraint => $self
+ ));
return $self;
}
-sub name { join ' | ' => map { $_->name } @{$_[0]->type_constraints} }
-
-# NOTE:
-# this should probably never be used
-# but we include it here for completeness
-sub constraint {
+sub _actually_compile_type_constraint {
my $self = shift;
- sub { $self->check($_[0]) };
+
+ my @constraints = @{ $self->type_constraints };
+
+ return sub {
+ my $value = shift;
+ foreach my $type (@constraints) {
+ return 1 if $type->check($value);
+ }
+ return undef;
+ };
}
-# conform to the TypeConstraint API
-sub parent { undef }
-sub message { undef }
-sub has_message { 0 }
-# FIXME:
-# not sure what this should actually do here
-sub coercion { undef }
+sub equals {
+ my ( $self, $type_or_name ) = @_;
-# this should probably be memoized
-sub has_coercion {
- my $self = shift;
- foreach my $type (@{$self->type_constraints}) {
- return 1 if $type->has_coercion
- }
- return 0;
-}
+ my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
-# NOTE:
-# this feels too simple, and may not always DWIM
-# correctly, especially in the presence of
-# close subtype relationships, however it should
-# work for a fair percentage of the use cases
-sub coerce {
- my $self = shift;
- my $value = shift;
- foreach my $type (@{$self->type_constraints}) {
- if ($type->has_coercion) {
- my $temp = $type->coerce($value);
- return $temp if $self->check($temp);
- }
- }
- return undef;
-}
+ return unless $other->isa(__PACKAGE__);
-sub _compiled_type_constraint {
- my $self = shift;
- return sub {
- my $value = shift;
- foreach my $type (@{$self->type_constraints}) {
- return 1 if $type->check($value);
+ my @self_constraints = @{ $self->type_constraints };
+ my @other_constraints = @{ $other->type_constraints };
+
+ return unless @self_constraints == @other_constraints;
+
+ # FIXME presort type constraints for efficiency?
+ constraint: foreach my $constraint ( @self_constraints ) {
+ for ( my $i = 0; $i < @other_constraints; $i++ ) {
+ if ( $constraint->equals($other_constraints[$i]) ) {
+ splice @other_constraints, $i, 1;
+ next constraint;
+ }
}
- return undef;
}
+
+ return @other_constraints == 0;
}
-sub check {
- my $self = shift;
- my $value = shift;
- $self->_compiled_type_constraint->($value);
+sub parents {
+ my $self = shift;
+ $self->type_constraints;
}
sub validate {
- my $self = shift;
- my $value = shift;
+ my ($self, $value) = @_;
my $message;
foreach my $type (@{$self->type_constraints}) {
my $err = $type->validate($value);
$message .= ($message ? ' and ' : '') . $err
if defined $err;
}
- return ($message . ' in (' . $self->name . ')') ;
+ return ($message . ' in (' . $self->name . ')') ;
}
sub is_a_type_of {
foreach my $type (@{$self->type_constraints}) {
return 1 if $type->is_a_type_of($type_name);
}
- return 0;
+ return 0;
}
sub is_subtype_of {
return 0;
}
+sub create_child_type {
+ my ( $self, %opts ) = @_;
+
+ my $constraint
+ = Moose::Meta::TypeConstraint->new( %opts, parent => $self );
+
+ # 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
+ # handle this differently.
+ # - SL
+ if ( not( defined $opts{constraint} )
+ && $self->has_coercion ) {
+ $constraint->coercion(
+ Moose::Meta::TypeCoercion::Union->new(
+ type_constraint => $self,
+ )
+ );
+ }
+
+ return $constraint;
+}
+
1;
__END__
=head1 DESCRIPTION
-This metaclass represents a union of Moose type constraints. More
-details to be explained later (possibly in a Cookbook::Recipe).
+This metaclass represents a union of type constraints. A union takes
+multiple type constraints, and is true if any one of its member
+constraints is true.
-This actually used to be part of Moose::Meta::TypeConstraint, but it
-is now better off in it's own file.
+=head1 INHERITANCE
-=head1 METHODS
-
-This class is not a subclass of Moose::Meta::TypeConstraint,
-but it does provide the same API
+C<Moose::Meta::TypeConstraint::Union> is a subclass of
+L<Moose::Meta::TypeConstraint>.
=over 4
-=item B<meta>
+=item B<< Moose::Meta::TypeConstraint::Union->new(%options) >>
-=item B<new>
+This creates a new class type constraint based on the given
+C<%options>.
-=item B<name>
+It takes the same options as its parent. It also requires an
+additional option, C<type_constraints>. This is an array reference
+containing the L<Moose::Meta::TypeConstraint> objects that are the
+members of the union type. The C<name> option defaults to the names
+all of these member types sorted and then joined by a pipe (|).
-=item B<type_constraints>
+The constructor sets the implementation of the constraint so that is
+simply calls C<check> on the newly created object.
-=item B<constraint>
+Finally, the constructor also makes sure that the object's C<coercion>
+attribute is a L<Moose::Meta::TypeCoercion::Union> object.
-=back
+=item B<< $constraint->type_constraints >>
-=head2 Overriden methods
+This returns the array reference of C<type_constraints> provided to
+the constructor.
-=over 4
-
-=item B<check>
+=item B<< $constraint->parents >>
-=item B<coerce>
+This returns the same constraint as the C<type_constraints> method.
-=item B<validate>
+=item B<< $constraint->check($value) >>
-=item B<is_a_type_of>
+=item B<< $constraint->validate($value) >>
-=item B<is_subtype_of>
+These two methods simply call the relevant method on each of the
+member type constraints in the union. If any type accepts the value,
+the value is valid.
-=back
+With C<validate> the error message returned includes all of the error
+messages returned by the member type constraints.
-=head2 Empty or Stub methods
+=item B<< $constraint->equals($type_name_or_object) >>
-These methods tend to not be very relevant in
-the context of a union. Either that or they are
-just difficult to specify and not very useful
-anyway. They are here for completeness.
+A type is considered equal if it is also a union type, and the two
+unions have the same member types.
-=over 4
+=item B<< $constraint->is_a_type_of($type_name_or_object) >>
-=item B<parent>
+This returns true if any of the member type constraints return true
+for the C<is_a_type_of> method.
-=item B<coercion>
+=item B<< $constraint->is_subtype_of >>
-=item B<has_coercion>
+This returns true if any of the member type constraints return true
+for the C<is_a_subtype_of> method.
-=item B<message>
+=item B<< $constraint->create_child_type(%options) >>
-=item B<has_message>
+This returns a new L<Moose::Meta::TypeConstraint> object with the type
+as its parent.
=back
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
=head1 COPYRIGHT AND LICENSE
-Copyright 2006, 2007 by Infinity Interactive, Inc.
+Copyright 2006-2009 by Infinity Interactive, Inc.
L<http://www.iinteractive.com>
projects / gitmo/Moose.git / blobdiff