From: Shawn M Moore <sartak@gmail.com>
Date: Thu, 27 Mar 2008 04:12:48 +0000 (+0000)
Subject: Implementation of TypeConstraint::Union->includes_type, and use it in Attribute.
X-Git-Tag: 0_55~253
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1b58cb9fb33a0ed1c874524e6116d78bee61a08b;p=gitmo%2FMoose.git

Implementation of TypeConstraint::Union->includes_type, and use it in Attribute.
---

diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index f8d539e..0cadb82 100644
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -105,10 +105,14 @@ sub clone_and_inherit_options {
         # NOTE:
         # check here to see if the new type
         # is a subtype of the old one
-        ($type_constraint->is_subtype_of($self->type_constraint->name))
-            || confess "New type constraint setting must be a subtype of inherited one"
-                # iff we have a type constraint that is ...
-                if $self->has_type_constraint;
+        # or if the old one is a union and the
+        # subtype (or a supertype of it) is included
+        # in the union
+        $type_constraint->is_subtype_of($self->type_constraint->name)
+            || ($self->type_constraint->can('includes_type') && $self->type_constraint->includes_type($type_constraint))
+                || confess "New type constraint setting must be a subtype of inherited one" . ($self->type_constraint->can('includes_type') ? ", or included in the inherited constraint" : '')
+                    # iff we have a type constraint that is ...
+                    if $self->has_type_constraint;
         # then we use it :)
         $actual_options{type_constraint} = $type_constraint;
         delete $options{isa};
diff --git a/lib/Moose/Meta/TypeConstraint/Union.pm b/lib/Moose/Meta/TypeConstraint/Union.pm
index a7e79d0..1337b0e 100644
--- a/lib/Moose/Meta/TypeConstraint/Union.pm
+++ b/lib/Moose/Meta/TypeConstraint/Union.pm
@@ -68,6 +68,31 @@ sub is_subtype_of {
     return 0;
 }
 
+sub includes_type {
+    my ($self, $type) = @_;
+
+    my $has_type = sub {
+        my $subtype = shift;
+
+        for my $type (@{ $self->type_constraints }) {
+            return 1 if $subtype->is_a_type_of($type);
+        }
+
+        return 0;
+    };
+
+    if ($type->isa('Moose::Meta::TypeConstraint::Union')) {
+        for my $t (@{ $type->type_constraints }) {
+            return 0 unless $has_type->($t);
+        }
+    }
+    else {
+        return 0 unless $has_type->($type);
+    }
+
+    return 1;
+}
+
 1;
 
 __END__
@@ -103,6 +128,8 @@ but it does provide the same API
 
 =item B<constraint>
 
+=item B<includes_type>
+
 =back
 
 =head2 Overriden methods