use warnings;
use metaclass;
-our $VERSION = '0.06';
+use Moose::Meta::TypeCoercion::Union;
+
+our $VERSION = '0.67';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-# NOTE:
-# this is not really correct, but
-# I think it shoul be here anyway.
-# In truth, this should implement
-# the same abstract base/interface
-# as the TC moule.
-# - SL
use base 'Moose::Meta::TypeConstraint';
__PACKAGE__->meta->add_attribute('type_constraints' => (
));
sub new {
- my $class = shift;
- my $self = $class->meta->new_object(@_);
+ my ($class, %options) = @_;
+ my $self = $class->SUPER::new(
+ name => (join '|' => sort {$a cmp $b}
+ map { $_->name } @{$options{type_constraints}}),
+ parent => undef,
+ message => undef,
+ hand_optimized_type_constraint => undef,
+ compiled_type_constraint => sub {
+ my $value = shift;
+ foreach my $type (@{$options{type_constraints}}) {
+ return 1 if $type->check($value);
+ }
+ return undef;
+ },
+ %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} }
+sub equals {
+ my ( $self, $type_or_name ) = @_;
-# NOTE:
-# this should probably never be used
-# but we include it here for completeness
-sub constraint {
- my $self = shift;
- sub { $self->check($_[0]) };
-}
+ my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
-# conform to the TypeConstraint API
-sub parent { undef }
-sub message { undef }
-sub has_message { 0 }
+ return unless $other->isa(__PACKAGE__);
-# FIXME:
-# not sure what this should actually do here
-sub coercion { undef }
+ my @self_constraints = @{ $self->type_constraints };
+ my @other_constraints = @{ $other->type_constraints };
-# 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;
-}
+ return unless @self_constraints == @other_constraints;
-# 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);
+ # 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;
-}
-sub _compiled_type_constraint {
- my $self = shift;
- return sub {
- my $value = shift;
- foreach my $type (@{$self->type_constraints}) {
- return 1 if $type->check($value);
- }
- 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);
return 0;
}
-## hand optimized constraints
-
-# NOTE:
-# it will just use all the hand optimized
-# type constraints from it's list of type
-# constraints automatically, but there is
-# no simple way to optimize it even more
-# (without B::Deparse or something). So
-# we just stop here.
-# - SL
+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,
+ )
+ );
+ }
-sub has_hand_optimized_type_constraint { 0 }
-sub hand_optimized_type_constraint { undef }
+ return $constraint;
+}
1;
=head1 DESCRIPTION
This metaclass represents a union of Moose type constraints. More
-details to be explained later (possibly in a Cookbook::Recipe).
+details to be explained later (possibly in a Cookbook recipe).
This actually used to be part of Moose::Meta::TypeConstraint, but it
is now better off in it's own file.
=item B<type_constraints>
+=item B<parents>
+
=item B<constraint>
+=item B<includes_type>
+
+=item B<equals>
+
=back
=head2 Overriden methods
=item B<has_hand_optimized_type_constraint>
+=item B<create_child_type>
+
=back
=head1 BUGS
=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