X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FTypeConstraint%2FUnion.pm;h=1aa8354353cb0a04ed945e1adc9e82faeb68a2ef;hb=aead17e74252e3884f9f8e39912ca98fdf4b4dd5;hp=916711153b07926791d7be80fc4fe6f71559d4cb;hpb=8ee73eeb7e76858f1dbe56f69101a2dc1e096559;p=gitmo%2FMoose.git
diff --git a/lib/Moose/Meta/TypeConstraint/Union.pm b/lib/Moose/Meta/TypeConstraint/Union.pm
index 9167111..1aa8354 100644
--- a/lib/Moose/Meta/TypeConstraint/Union.pm
+++ b/lib/Moose/Meta/TypeConstraint/Union.pm
@@ -5,7 +5,13 @@ use strict;
use warnings;
use metaclass;
-our $VERSION = '0.03';
+use Moose::Meta::TypeCoercion::Union;
+
+our $VERSION = '0.62';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::TypeConstraint';
__PACKAGE__->meta->add_attribute('type_constraints' => (
accessor => 'type_constraints',
@@ -13,76 +19,61 @@ __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);
@@ -109,10 +100,132 @@ 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__
=pod
+=head1 NAME
+
+Moose::Meta::TypeConstraint::Union - A union of Moose type constraints
+
+=head1 DESCRIPTION
+
+This metaclass represents a union of Moose type constraints. More
+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.
+
+=head1 METHODS
+
+This class is not a subclass of Moose::Meta::TypeConstraint,
+but it does provide the same API
+
+=over 4
+
+=item B
+
+=item B
+
+=item B
+
+=item B
+
+=item B
+
+=item B
+
+=item B
+
+=item B
+
+=back
+
+=head2 Overriden methods
+
+=over 4
+
+=item B
+
+=item B
+
+=item B
+
+=item B
+
+=item B
+
+=back
+
+=head2 Empty or Stub methods
+
+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.
+
+=over 4
+
+=item B
+
+=item B
+
+=item B
+
+=item B
+
+=item B
+
+=item B
+
+=item B
+
+=item B
+
+=back
+
+=head1 BUGS
+
+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 AUTHOR
+
+Stevan Little Estevan@iinteractive.comE
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 by Infinity Interactive, Inc.
+
+L
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
=cut